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 #lang racket/base
(require scheme/contract (require racket/contract
"model/trace.ss" "model/trace.rkt"
"model/reductions-config.ss" "model/reductions-config.rkt"
"model/reductions.ss") "model/reductions.rkt")
(provide/contract (provide/contract
[expand-only [expand-only

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

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

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

@ -4,6 +4,7 @@
scribble/eval scribble/eval
(for-label scheme/base (for-label scheme/base
macro-debugger/expand macro-debugger/expand
macro-debugger/emit
macro-debugger/stepper macro-debugger/stepper
macro-debugger/stepper-text macro-debugger/stepper-text
macro-debugger/syntax-browser macro-debugger/syntax-browser
@ -101,6 +102,58 @@ thing as the original syntax.
(lambda (id) (memq (syntax-e id) '(or #%app)))))) (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} @section{Macro stepper text interface}
@defmodule[macro-debugger/stepper-text] @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) (require syntax/stx)
(provide (struct-out ref) (provide (struct-out ref)
(struct-out tail) (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 (provide (all-from-out "trace.rkt")
"trace.ss" (all-from-out "reductions.rkt")
"reductions.ss" (all-from-out "reductions-config.rkt")
"reductions-config.ss" (all-from-out "deriv.rkt")
"deriv-util.ss" (all-from-out "deriv-util.rkt")
"hiding-policies.ss" (all-from-out "hiding-policies.rkt")
"deriv.ss" (all-from-out "steps.rkt")
"steps.ss") (all-from-out racket/match))
(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))

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

@ -1,5 +1,4 @@
#lang racket/base
#lang scheme/base
(provide (all-defined-out)) (provide (all-defined-out))
;; A Node(a) is: ;; A Node(a) is:
@ -40,6 +39,8 @@
(define-struct local-lift-require (req expr mexpr) #:transparent) (define-struct local-lift-require (req expr mexpr) #:transparent)
(define-struct local-lift-provide (prov) #:transparent) (define-struct local-lift-provide (prov) #:transparent)
(define-struct local-bind (names ?1 renames bindrhs) #:transparent) (define-struct local-bind (names ?1 renames bindrhs) #:transparent)
(define-struct local-remark (contents) #:transparent)
;; contents : (listof (U string syntax))
;; A PrimDeriv is one of ;; A PrimDeriv is one of
(define-struct (prule base) () #:transparent) (define-struct (prule base) () #:transparent)

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

@ -1,12 +1,11 @@
#lang racket/base
#lang scheme/base (require (for-syntax racket/base)
(require (for-syntax scheme/base)
syntax/stx syntax/stx
"yacc-ext.ss" "yacc-ext.rkt"
"yacc-interrupted.ss" "yacc-interrupted.rkt"
"deriv.ss" "deriv.rkt"
"deriv-util.ss" "deriv-util.rkt"
"deriv-tokens.ss") "deriv-tokens.rkt")
(provide parse-derivation) (provide parse-derivation)
(define (deriv-error ok? name value start end) (define (deriv-error ok? name value start end)
@ -202,6 +201,20 @@
(make local-bind $1 $2 $3 #f)] (make local-bind $1 $2 $3 #f)]
[(local-bind rename-list (? BindSyntaxes)) [(local-bind rename-list (? BindSyntaxes))
(make local-bind $1 #f $2 $3)] (make local-bind $1 #f $2 $3)]
[(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 ;; -- Not really local actions, but can occur during evaluation
;; called 'expand' (not 'local-expand') within transformer ;; called 'expand' (not 'local-expand') within transformer
[(start (? EE)) #f] [(start (? EE)) #f]

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

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

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

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

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

@ -1,368 +1,5 @@
#lang racket/base
#lang scheme/base (require racket/contract
(require scheme/contract
syntax/stx syntax/stx
"deriv-c.ss") "deriv-c.rkt")
(provide (all-from-out "deriv-c.rkt"))
(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?])))
|#

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,14 +1,14 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/gui racket/gui
scheme/list racket/list
(rename-in unstable/class-iop racket/block
[send/i send:] framework
[init-field/i init-field:]) unstable/class-iop
(only-in mzlib/etc begin-with-definitions) "pretty-printer.rkt"
"pretty-printer.ss" "interfaces.rkt"
"interfaces.ss" "prefs.rkt"
"util.ss") "util.rkt")
(provide print-syntax-to-editor (provide print-syntax-to-editor
code-style) code-style)
@ -25,13 +25,13 @@
;; -> display<%> ;; -> display<%>
(define (print-syntax-to-editor stx text controller config columns (define (print-syntax-to-editor stx text controller config columns
[insertion-point (send text last-position)]) [insertion-point (send text last-position)])
(begin-with-definitions (block
(define output-port (open-output-string/count-lines)) (define output-port (open-output-string/count-lines))
(define range (define range
(pretty-print-syntax stx output-port (pretty-print-syntax stx output-port
(send: controller controller<%> get-primary-partition) (send/i controller controller<%> get-primary-partition)
(length (send: config config<%> get-colors)) (length (send/i config config<%> get-colors))
(send: config config<%> get-suffix-option) (send/i config config<%> get-suffix-option)
(send config get-pretty-styles) (send config get-pretty-styles)
columns)) columns))
(define output-string (get-output-string output-port)) (define output-string (get-output-string output-port))
@ -54,15 +54,15 @@
;; display% ;; display%
(define display% (define display%
(class* object% (display<%>) (class* object% (display<%>)
(init-field: [controller controller<%>] (init-field/i [controller controller<%>]
[config config<%>] [config config<%>]
[range range<%>]) [range range<%>])
(init-field text (init-field text
start-position start-position
end-position) end-position)
(define base-style (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)) (define extra-styles (make-hasheq))
@ -76,10 +76,10 @@
;; add-clickbacks : -> void ;; add-clickbacks : -> void
(define/private (add-clickbacks) (define/private (add-clickbacks)
(define (the-clickback editor start end) (define (the-clickback editor start end)
(send: controller selection-manager<%> set-selected-syntax (send/i controller selection-manager<%> set-selected-syntax
(clickback->stx (clickback->stx
(- start start-position) (- end start-position)))) (- 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)] (let ([stx (range-obj range)]
[start (range-start range)] [start (range-start range)]
[end (range-end range)]) [end (range-end range)])
@ -89,7 +89,7 @@
;; clickback->stx : num num -> syntax ;; clickback->stx : num num -> syntax
;; FIXME: use vectors for treerange-subs and do binary search to narrow? ;; FIXME: use vectors for treerange-subs and do binary search to narrow?
(define/private (clickback->stx start end) (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]) (let loop* ([treeranges treeranges])
(for/or ([tr treeranges]) (for/or ([tr treeranges])
(cond [(and (= (treerange-start tr) start) (cond [(and (= (treerange-start tr) start)
@ -106,12 +106,12 @@
(with-unlock text (with-unlock text
(send* text (send* text
(begin-edit-sequence #f) (begin-edit-sequence #f)
(change-style unhighlight-d start-position end-position)) (change-style (unhighlight-d) start-position end-position))
(apply-extra-styles) (apply-extra-styles)
(let ([selected-syntax (let ([selected-syntax
(send: controller selection-manager<%> (send/i controller selection-manager<%>
get-selected-syntax)]) get-selected-syntax)])
(apply-secondary-partition-styles selected-syntax) (apply-secondary-relation-styles selected-syntax)
(apply-selection-styles selected-syntax)) (apply-selection-styles selected-syntax))
(send* text (send* text
(end-edit-sequence)))) (end-edit-sequence))))
@ -157,13 +157,16 @@
(send delta set-delta-foreground color) (send delta set-delta-foreground color)
(send style-list find-or-create-style base-style delta))) (send style-list find-or-create-style base-style delta)))
(define color-styles (define color-styles
(list->vector (map color-style (send: config config<%> get-colors)))) (list->vector
(define overflow-style (color-style "darkgray")) (map color-style
(map translate-color
(send/i config config<%> get-colors)))))
(define overflow-style (color-style (translate-color "darkgray")))
(define color-partition (define color-partition
(send: controller mark-manager<%> get-primary-partition)) (send/i controller mark-manager<%> get-primary-partition))
(define offset start-position) (define offset start-position)
;; Optimization: don't call change-style when new style = old style ;; 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]) (for ([tr trs])
(define stx (treerange-obj tr)) (define stx (treerange-obj tr))
(define start (treerange-start tr)) (define start (treerange-start tr))
@ -179,7 +182,7 @@
;; primary-style : syntax partition (vector-of style-delta%) style-delta% ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
;; -> style-delta% ;; -> style-delta%
(define/private (primary-style stx partition color-vector overflow) (define/private (primary-style stx partition color-vector overflow)
(let ([n (send: partition partition<%> get-partition stx)]) (let ([n (send/i partition partition<%> get-partition stx)])
(cond [(< n (vector-length color-vector)) (cond [(< n (vector-length color-vector))
(vector-ref color-vector n)] (vector-ref color-vector n)]
[else [else
@ -192,34 +195,34 @@
;; Applies externally-added styles (such as highlighting) ;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles) (define/private (apply-extra-styles)
(for ([(stx style-deltas) extra-styles]) (for ([(stx 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]) (for ([style-delta style-deltas])
(restyle-range r style-delta))))) (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 ;; If the selected syntax is an identifier, then styles all identifiers
;; in the same partition in blue. ;; in the relation with it.
(define/private (apply-secondary-partition-styles selected-syntax) (define/private (apply-secondary-relation-styles selected-syntax)
(when (identifier? selected-syntax) (when (identifier? selected-syntax)
(let ([partition (let* ([name+relation
(send: controller secondary-partition<%> (send/i controller secondary-relation<%>
get-secondary-partition)]) get-identifier=?)]
(when partition [relation (and name+relation (cdr name+relation))])
(for ([id (send: range range<%> get-identifier-list)]) (when relation
(when (send: partition partition<%> (for ([id (send/i range range<%> get-identifier-list)])
same-partition? selected-syntax id) (when (relation selected-syntax id)
(draw-secondary-connection id))))))) (draw-secondary-connection id)))))))
;; apply-selection-styles : syntax -> void ;; apply-selection-styles : syntax -> void
;; Styles subterms eq to the selected syntax ;; Styles subterms eq to the selected syntax
(define/private (apply-selection-styles selected-syntax) (define/private (apply-selection-styles selected-syntax)
(for ([r (send: range range<%> get-ranges selected-syntax)]) (for ([r (send/i range range<%> get-ranges selected-syntax)])
(restyle-range r select-highlight-d))) (restyle-range r (select-highlight-d))))
;; draw-secondary-connection : syntax -> void ;; draw-secondary-connection : syntax -> void
(define/private (draw-secondary-connection stx2) (define/private (draw-secondary-connection stx2)
(for ([r (send: range range<%> get-ranges stx2)]) (for ([r (send/i range range<%> get-ranges stx2)])
(restyle-range r select-sub-highlight-d))) (restyle-range r (select-sub-highlight-d))))
;; restyle-range : (cons num num) style-delta% -> void ;; restyle-range : (cons num num) style-delta% -> void
(define/private (restyle-range r style) (define/private (restyle-range r style)
@ -233,11 +236,11 @@
;; Initialize ;; Initialize
(super-new) (super-new)
(send: controller controller<%> add-syntax-display this))) (send/i controller controller<%> add-syntax-display this)))
;; fixup-parentheses : string range -> void ;; fixup-parentheses : string range -> void
(define (fixup-parentheses string range) (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)] (let ([stx (range-obj r)]
[start (range-start r)] [start (range-start r)]
[end (range-end r)]) [end (range-end r)])
@ -258,7 +261,7 @@
;; code-style : text<%> number/#f -> style<%> ;; code-style : text<%> number/#f -> style<%>
(define (code-style text font-size) (define (code-style text font-size)
(let* ([style-list (send text get-style-list)] (let* ([style-list (send text get-style-list)]
[style (send style-list find-named-style "Standard")]) [style (send style-list find-named-style (editor:get-default-color-style-name))])
(if font-size (if font-size
(send style-list find-or-create-style (send style-list find-or-create-style
style style
@ -272,13 +275,98 @@
(make-object string-snip% "")) (make-object string-snip% ""))
(super-instantiate ()))) (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 ;; Styles
(define (highlight-style-delta color em?) (define (highlight-style-delta raw-color em?
(let ([sd (new style-delta%)]) #:translate-color? [translate-color? #t])
(unless em? (send sd set-delta-background color)) (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)) (when em? (send sd set-weight-on 'bold))
(unless em? (send sd set-underlined-off #t) (unless em?
;; (send sd set-underlined-off #t)
(send sd set-weight-off 'bold)) (send sd set-weight-off 'bold))
sd)) sd))
@ -287,10 +375,17 @@
(send sd set-underlined-on #t) (send sd set-underlined-on #t)
sd)) sd))
(define selection-color "yellow") (define (mk-2-constant-style bow-color em? [wob-color (translate-color bow-color)])
(define subselection-color "yellow") (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-highlight-d
(define select-sub-highlight-d (highlight-style-delta subselection-color #f)) (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 (provide (all-from-out "interfaces.rkt")
(require "interfaces.ss" (all-from-out "widget.rkt")
"widget.ss" (all-from-out "keymap.rkt")
"keymap.ss"
"partition.ss")
(provide (all-from-out "interfaces.ss")
(all-from-out "widget.ss")
(all-from-out "keymap.ss")
identifier=-choices) identifier=-choices)

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

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

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

@ -1,8 +1,6 @@
#lang racket/base
#lang scheme/base (require racket/class
racket/gui)
(require scheme/class
scheme/gui)
(provide hrule-snip%) (provide hrule-snip%)
;; hrule-snip% ;; hrule-snip%
@ -53,5 +51,5 @@
(define snip-class (new hrule-snipclass%)) (define snip-class (new hrule-snipclass%))
(send snip-class set-version 1) (send snip-class set-version 1)
(send snip-class set-classname (send snip-class set-classname
(format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser"))) (format "~s" '(lib "hrule-snip.rkt" "macro-debugger" "syntax-browser")))
(send (get-the-snip-class-list) add snip-class) (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 #lang racket/base
(require scheme/contract (require racket/contract
scheme/class racket/class
scheme/gui racket/gui
framework framework
"prefs.ss" "prefs.rkt"
"controller.ss" "controller.rkt"
"display.ss") "display.rkt")
#| #|
@ -36,7 +36,7 @@ TODO: tacked arrows
;; print-syntax-columns : (parameter-of (U number 'infinity)) ;; print-syntax-columns : (parameter-of (U number 'infinity))
(define print-syntax-columns (make-parameter 40)) (define print-syntax-columns (make-parameter 40))
(define standard-text% (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 ;; print-syntax-to-png : syntax path -> void
(define (print-syntax-to-png stx file (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 dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1))))
(define char-width (define char-width
(let* ([sl (send t get-style-list)] (let* ([sl (send t get-style-list)]
[style (send sl find-named-style "Standard")] [style (send sl find-named-style (editor:get-default-color-style-name))]
[font (send style get-font)]) [font (send style get-font)])
(send dc set-font font) (send dc set-font font)
(send dc get-char-width))) (send dc get-char-width)))
@ -89,7 +89,7 @@ TODO: tacked arrows
(define (prepare-editor stx columns) (define (prepare-editor stx columns)
(define t (new standard-text%)) (define t (new standard-text%))
(define sl (send t get-style-list)) (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 (print-syntax-to-editor stx t
(new controller%) (new syntax-prefs/readonly%) (new controller%) (new syntax-prefs/readonly%)
columns (send t last-position)) columns (send t last-position))

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

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

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

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

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

@ -1,157 +1,45 @@
#lang racket/base
#lang scheme/base (require racket/class
(require scheme/class
syntax/boundmap
syntax/stx syntax/stx
"interfaces.ss") "interfaces.rkt"
"../util/stxobj.rkt")
(provide new-bound-partition (provide new-bound-partition
partition%
identifier=-choices) identifier=-choices)
(define (new-bound-partition) (define (new-bound-partition)
(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% ;; bound-partition%
(define bound-partition% (define bound-partition%
(class* object% (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 next-number 0)
(define/public (get-partition stx) (define/public (get-partition stx)
(let* ([r (representative stx)] (let ([marks (simplify-marks (get-marks stx))])
[n (bound-identifier-mapping-get numbers r (lambda _ #f))]) (or (hash-ref simplified marks #f)
(or n (let ([n next-number])
(begin0 next-number (hash-set! simplified marks n)
(bound-identifier-mapping-put! numbers r next-number) (set! next-number (add1 n))
#;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax->datum stx)) n))))
(set! next-number (add1 next-number))))))
(define/public (same-partition? a b) (define/public (same-partition? a b)
(= (get-partition a) (get-partition b))) (= (get-partition a) (get-partition b)))
(define/public (count) (define/public (count)
next-number) next-number)
(define/private (representative stx)
(datum->syntax stx representative-symbol))
(get-partition unmarked-syntax) (get-partition (datum->syntax #f 'nowhere))
(super-new))) (super-new)))
;; Different identifier relations for highlighting. ;; ==== Identifier relations ====
(define (lift/rep id=?)
(lambda (A B)
(let ([ra (datum->syntax A representative-symbol)]
[rb (datum->syntax B representative-symbol)])
(id=? ra rb))))
(define (lift id=?)
(lambda (A B)
(and (identifier? A) (identifier? B) (id=? A B))))
;; id:same-marks? : syntax syntax -> boolean
(define id:same-marks?
(lift/rep bound-identifier=?))
;; id:X-module=? : identifier identifier -> boolean
;; If both module-imported, do they come from the same module?
;; If both top-bound, then same source.
(define (id:source-module=? a b)
(let ([ba (identifier-binding a)]
[bb (identifier-binding b)])
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
(free-identifier=? a b)]
[(and (not ba) (not bb))
#t]
[(or (not ba) (not bb))
#f]
[else
(eq? (car ba) (car bb))])))
(define (id:nominal-module=? A B)
(let ([ba (identifier-binding A)]
[bb (identifier-binding B)])
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
(free-identifier=? A B)]
[(or (not ba) (not bb))
(and (not ba) (not bb))]
[else (eq? (caddr ba) (caddr bb))])))
(define (symbolic-identifier=? A B)
(eq? (syntax-e A) (syntax-e B)))
(define identifier=-choices (define identifier=-choices
(make-parameter (make-parameter
`(("<nothing>" . #f) `(("<nothing>" . #f)
("bound-identifier=?" . ,bound-identifier=?) ("bound-identifier=?" . ,bound-identifier=?)
("free-identifier=?" . ,free-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=?))))

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

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

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

@ -1,11 +1,10 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/pretty racket/pretty
(rename-in unstable/class-iop unstable/class-iop
[send/i send:])
syntax/stx syntax/stx
unstable/struct unstable/struct
"interfaces.ss") "interfaces.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
@ -32,7 +31,7 @@
[print-vector-length #f] [print-vector-length #f]
[print-hash-table #t] [print-hash-table #t]
[print-honu #f]) [print-honu #f])
(pretty-print datum port))) (pretty-write datum port)))
(define-struct syntax-dummy (val)) (define-struct syntax-dummy (val))
(define-struct (id-syntax-dummy syntax-dummy) (remap)) (define-struct (id-syntax-dummy syntax-dummy) (remap))
@ -64,12 +63,12 @@
((never) ((never)
(make-id-syntax-dummy sym sym)) (make-id-syntax-dummy sym sym))
((always) ((always)
(let ([n (send: partition partition<%> get-partition id)]) (let ([n (send/i partition partition<%> get-partition id)])
(if (zero? n) (if (zero? n)
(make-id-syntax-dummy sym sym) (make-id-syntax-dummy sym sym)
(make-id-syntax-dummy (suffix sym n) sym)))) (make-id-syntax-dummy (suffix sym n) sym))))
((over-limit) ((over-limit)
(let ([n (send: partition partition<%> get-partition id)]) (let ([n (send/i partition partition<%> get-partition id)])
(if (<= n limit) (if (<= n limit)
(make-id-syntax-dummy sym sym) (make-id-syntax-dummy sym sym)
(make-id-syntax-dummy (suffix sym n) sym)))))) (make-id-syntax-dummy (suffix sym n) sym))))))
@ -82,7 +81,7 @@
=> (lambda (datum) datum)] => (lambda (datum) datum)]
[(and partition (identifier? obj)) [(and partition (identifier? obj))
(when (and (eq? suffixopt 'all-if-over-limit) (when (and (eq? suffixopt 'all-if-over-limit)
(> (send: partition partition<%> count) limit)) (> (send/i partition partition<%> count) limit))
(call-with-values (lambda () (table stx partition #f 'always)) (call-with-values (lambda () (table stx partition #f 'always))
escape)) escape))
(let ([lp-datum (make-identifier-proxy obj)]) (let ([lp-datum (make-identifier-proxy obj)])
@ -91,7 +90,7 @@
lp-datum)] lp-datum)]
[(and (syntax? obj) (check+convert-special-expression obj)) [(and (syntax? obj) (check+convert-special-expression obj))
=> (lambda (newobj) => (lambda (newobj)
(when partition (send: partition partition<%> get-partition obj)) (when partition (send/i partition partition<%> get-partition obj))
(let* ([inner (cadr newobj)] (let* ([inner (cadr newobj)]
[lp-inner-datum (loop inner)] [lp-inner-datum (loop inner)]
[lp-datum (list (car newobj) lp-inner-datum)]) [lp-datum (list (car newobj) lp-inner-datum)])
@ -101,7 +100,7 @@
(hash-set! stx=>flat obj lp-datum) (hash-set! stx=>flat obj lp-datum)
lp-datum))] lp-datum))]
[(syntax? obj) [(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))]) (let ([lp-datum (loop (syntax-e obj))])
(hash-set! flat=>stx lp-datum obj) (hash-set! flat=>stx lp-datum obj)
(hash-set! stx=>flat obj lp-datum) (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 #lang racket/base
(require scheme/list (require racket/list
scheme/class racket/class
scheme/pretty racket/pretty
scheme/gui racket/gui
"pretty-helper.ss" "pretty-helper.rkt"
"interfaces.ss") "interfaces.rkt")
(provide pretty-print-syntax) (provide pretty-print-syntax)
;; FIXME: Need to disable printing of structs with custom-write property ;; 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 #lang racket/base
(require scheme/class (require racket/class
scheme/gui racket/gui
(rename-in unstable/class-iop framework
[send/i send:]) unstable/class-iop
"interfaces.ss" "interfaces.rkt"
"util.ss" "util.rkt"
"../util/mpi.ss") "../util/mpi.rkt"
"../util/stxobj.rkt")
(provide properties-view% (provide properties-view%
properties-snip%) 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 ;; properties-view-base-mixin
(define properties-view-base-mixin (define properties-view-base-mixin
(mixin () () (mixin () ()
@ -22,13 +40,13 @@
(define mode 'term) (define mode 'term)
;; text : text% ;; text : text%
(field (text (new text%))) (field (text (new color-text%)))
(field (pdisplayer (new properties-displayer% (text text)))) (field (pdisplayer (new properties-displayer% (text text))))
(send: controller selection-manager<%> listen-selected-syntax (send/i controller selection-manager<%> listen-selected-syntax
(lambda (stx) (lambda (stx)
(set! selected-syntax stx) (set! selected-syntax stx)
(refresh))) (refresh)))
(super-new) (super-new)
;; get-mode : -> symbol ;; get-mode : -> symbol
@ -122,7 +140,7 @@
(callback (callback
(lambda (tp e) (lambda (tp e)
(set-mode (cdr (list-ref tab-choices (send tp get-selection)))))))) (set-mode (cdr (list-ref tab-choices (send tp get-selection))))))))
(define ecanvas (new editor-canvas% (editor text) (parent tab-panel))))) (define ecanvas (new canvas:color% (editor text) (parent tab-panel)))))
;; properties-displayer% ;; properties-displayer%
(define properties-displayer% (define properties-displayer%
@ -188,7 +206,8 @@
(define/public (display-stxobj-info stx) (define/public (display-stxobj-info stx)
(display-source-info stx) (display-source-info stx)
(display-extra-source-info stx) (display-extra-source-info stx)
(display-symbol-property-info stx)) (display-symbol-property-info stx)
(display-marks stx))
;; display-source-info : syntax -> void ;; display-source-info : syntax -> void
(define/private (display-source-info stx) (define/private (display-source-info stx)
@ -226,7 +245,13 @@
(display "No additional properties available.\n" n/a-sd)) (display "No additional properties available.\n" n/a-sd))
(when (pair? keys) (when (pair? keys)
(for-each (lambda (k) (display-subkv/value k (syntax-property stx k))) (for-each (lambda (k) (display-subkv/value k (syntax-property stx k)))
keys)))) keys))
(display "\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 ;; display-kv : any any -> void
(define/private (display-kv key value) (define/private (display-kv key value)

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

@ -1,14 +1,13 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
(rename-in unstable/class-iop racket/gui
[send/i send:]) (only-in mzlib/string read-from-string)
mzlib/string unstable/class-iop
mred "interfaces.rkt"
"interfaces.ss" "controller.rkt"
"controller.ss" "properties.rkt"
"properties.ss" "prefs.rkt"
"prefs.ss" (except-in "snip.rkt"
(except-in "snip.ss"
snip-class)) snip-class))
(provide decorated-syntax-snip% (provide decorated-syntax-snip%
@ -145,8 +144,8 @@
(define/public (read-special src line col pos) (define/public (read-special src line col pos)
(send the-syntax-snip read-special src line col pos)) (send the-syntax-snip read-special src line col pos))
(send: config config<%> listen-props-shown? (send/i config config<%> listen-props-shown?
(lambda (?) (refresh-contents))) (lambda (?) (refresh-contents)))
(super-new) (super-new)
(set-snipclass snip-class) (set-snipclass snip-class)
@ -198,7 +197,7 @@
;; SNIPCLASS ;; SNIPCLASS
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss ;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt
(define decorated-syntax-snipclass% (define decorated-syntax-snipclass%
(class snip-class% (class snip-class%
(define/override (read stream) (define/override (read stream)
@ -210,4 +209,4 @@
(define snip-class (make-object decorated-syntax-snipclass%)) (define snip-class (make-object decorated-syntax-snipclass%))
(send snip-class set-version 2) (send snip-class set-version 2)
(send snip-class set-classname (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 #lang racket/base
(require scheme/class (require racket/class
(rename-in unstable/class-iop racket/gui
[send/i send:]) racket/match
scheme/match (only-in mzlib/string read-from-string)
mzlib/string
mred
framework framework
"interfaces.ss" "interfaces.rkt"
"display.ss" "display.rkt"
"controller.ss" "controller.rkt"
"keymap.ss" "keymap.rkt"
"prefs.ss") "prefs.rkt")
(provide syntax-snip% (provide syntax-snip%
marshall-syntax marshall-syntax
@ -167,7 +165,7 @@
;; SNIPCLASS ;; SNIPCLASS
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss ;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt
(define syntax-snipclass% (define syntax-snipclass%
(class snip-class% (class snip-class%
(define/override (read stream) (define/override (read stream)
@ -178,4 +176,4 @@
(define snip-class (new syntax-snipclass%)) (define snip-class (new syntax-snipclass%))
(send snip-class set-version 2) (send snip-class set-version 2)
(send snip-class set-classname (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 #lang racket/base
(require scheme/list (require racket/list
scheme/class racket/class
scheme/gui racket/gui
drracket/arrow drracket/arrow
framework/framework framework/framework
unstable/interval-map unstable/interval-map
unstable/gui/notify unstable/gui/notify
"interfaces.ss") "interfaces.rkt")
(provide text:hover<%> (provide text:hover<%>
text:hover-drawings<%> text:hover-drawings<%>

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

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

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

@ -1,21 +1,20 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
mred racket/gui
framework/framework racket/list
scheme/list racket/match
scheme/match framework
syntax/id-table syntax/id-table
(rename-in unstable/class-iop unstable/class-iop
[send/i send:]) "interfaces.rkt"
"interfaces.ss" "controller.rkt"
"controller.ss" "display.rkt"
"display.ss" "keymap.rkt"
"keymap.ss" "hrule-snip.rkt"
"hrule-snip.ss" "properties.rkt"
"properties.ss" "text.rkt"
"text.ss" "util.rkt"
"util.ss" "../util/mpi.rkt")
"../util/mpi.ss")
(provide widget%) (provide widget%)
;; widget% ;; widget%
@ -33,7 +32,7 @@
(new panel:horizontal-dragable% (parent -main-panel))) (new panel:horizontal-dragable% (parent -main-panel)))
(define -text (new browser-text%)) (define -text (new browser-text%))
(define -ecanvas (define -ecanvas
(new editor-canvas% (parent -split-panel) (editor -text))) (new canvas:color% (parent -split-panel) (editor -text)))
(define -props-panel (new horizontal-panel% (parent -split-panel))) (define -props-panel (new horizontal-panel% (parent -split-panel)))
(define props (define props
(new properties-view% (new properties-view%
@ -55,7 +54,7 @@
(define/private (internal-show-props show?) (define/private (internal-show-props show?)
(if show? (if show?
(unless (send -props-panel is-shown?) (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) (send -split-panel add-child -props-panel)
(update-props-percentage p)) (update-props-percentage p))
(send -props-panel show #t)) (send -props-panel show #t))
@ -82,7 +81,7 @@
(define/public (shutdown) (define/public (shutdown)
(when (props-panel-shown?) (when (props-panel-shown?)
(send: config config<%> set-props-percentage (send/i config config<%> set-props-percentage
(cadr (send -split-panel get-percentages))))) (cadr (send -split-panel get-percentages)))))
;; syntax-browser<%> Methods ;; syntax-browser<%> Methods
@ -115,29 +114,29 @@
#:substitutions [substitutions null]) #:substitutions [substitutions null])
(let ([display (internal-add-syntax stx)] (let ([display (internal-add-syntax stx)]
[definite-table (make-hasheq)]) [definite-table (make-hasheq)])
(let ([range (send: display display<%> get-range)] (let ([range (send/i display display<%> get-range)]
[offset (send: display display<%> get-start-position)]) [offset (send/i display display<%> get-start-position)])
(for ([subst substitutions]) (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 (with-unlock -text
(send -text insert (cdr subst) (send -text insert (cdr subst)
(+ offset (car r)) (+ offset (car r))
(+ offset (cdr r)) (+ offset (cdr r))
#f) #f)
(send -text change-style (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 (car r))
(+ offset (cdr r))))))) (+ offset (cdr r)))))))
(for ([hi-stxs hi-stxss] [hi-color hi-colors]) (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]) (for ([definite definites])
(hash-set! definite-table definite #t) (hash-set! definite-table definite #t)
(when shift-table (when shift-table
(for ([shifted-definite (hash-ref shift-table definite null)]) (for ([shifted-definite (hash-ref shift-table definite null)])
(hash-set! definite-table shifted-definite #t)))) (hash-set! definite-table shifted-definite #t))))
(let ([binder-table (make-free-id-table)]) (let ([binder-table (make-free-id-table)])
(define range (send: display display<%> get-range)) (define range (send/i display display<%> get-range))
(define start (send: display display<%> get-start-position)) (define start (send/i display display<%> get-start-position))
(define (get-binders id) (define (get-binders id)
(let ([binder (free-id-table-ref binder-table id #f)]) (let ([binder (free-id-table-ref binder-table id #f)])
(cond [(not binder) null] (cond [(not binder) null]
@ -149,17 +148,17 @@
(for ([binder binders]) (for ([binder binders])
(free-id-table-set! binder-table binder binder)) (free-id-table-set! binder-table binder binder))
;; Underline binders (and shifted binders) ;; Underline binders (and shifted binders)
(send: display display<%> underline-syntaxes (send/i display display<%> underline-syntaxes
(append (apply append (map get-shifted binders)) (append (apply append (map get-shifted binders))
binders)) binders))
;; Make arrows (& billboards, when enabled) ;; 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)) (define definite? (hash-ref definite-table id #f))
(when #f ;; DISABLED (when #f ;; DISABLED
(add-binding-billboard start range id definite?)) (add-binding-billboard start range id definite?))
(for ([binder (get-binders id)]) (for ([binder (get-binders id)])
(for ([binder-r (send: range range<%> get-ranges binder)]) (for ([binder-r (send/i range range<%> get-ranges binder)])
(for ([id-r (send: range range<%> get-ranges id)]) (for ([id-r (send/i range range<%> get-ranges id)])
(add-binding-arrow start binder-r id-r definite?)))))) (add-binding-arrow start binder-r id-r definite?))))))
(void))) (void)))
@ -187,7 +186,7 @@
(+ start (cdr id-r)) (+ start (cdr id-r))
(string-append "from " (mpi->string src-mod)) (string-append "from " (mpi->string src-mod))
(if definite? "blue" "purple"))) (if definite? "blue" "purple")))
(send: range range<%> get-ranges id))] (send/i range range<%> get-ranges id))]
[_ (void)])) [_ (void)]))
(define/public (add-separator) (define/public (add-separator)
@ -200,7 +199,7 @@
(with-unlock -text (with-unlock -text
(send -text erase) (send -text erase)
(send -text delete-all-drawings)) (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) (define/public (get-text) -text)
@ -218,7 +217,7 @@
display))) display)))
(define/private (calculate-columns) (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 char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) (define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
(sub1 (inexact->exact (floor (/ canvas-w char-width))))) (sub1 (inexact->exact (floor (/ canvas-w char-width)))))
@ -227,13 +226,13 @@
(super-new) (super-new)
(setup-keymap) (setup-keymap)
(send: config config<%> listen-props-shown? (send/i config config<%> listen-props-shown?
(lambda (show?) (lambda (show?)
(show-props show?))) (show-props show?)))
(send: config config<%> listen-props-percentage (send/i config config<%> listen-props-percentage
(lambda (p) (lambda (p)
(update-props-percentage 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 (define clickback-style
@ -251,13 +250,20 @@
;; Specialized classes for widget ;; Specialized classes for widget
(define browser-text% (define browser-text%
(class (text:arrows-mixin (let ([browser-text-default-style-name "widget.rkt::browser-text% basic"])
(text:tacking-mixin (class (text:arrows-mixin
(text:hover-drawings-mixin (text:tacking-mixin
(text:hover-mixin (text:hover-drawings-mixin
(text:hide-caret/selection-mixin (text:hover-mixin
(editor:standard-style-list-mixin text:basic%)))))) (text:hide-caret/selection-mixin
(inherit set-autowrap-bitmap) (text:foreground-color-mixin
(define/override (default-style-name) "Basic") (editor:standard-style-list-mixin text:basic%)))))))
(super-new (auto-wrap #t)) (inherit set-autowrap-bitmap get-style-list)
(set-autowrap-bitmap #f))) (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 #lang racket/base
(require scheme/match) (require racket/match
racket/string)
(provide mpi->list (provide mpi->list
mpi->string) mpi->string
self-mpi?)
;; mpi->list : module-path-index -> list
(define (mpi->list mpi) (define (mpi->list mpi)
(cond [(module-path-index? mpi) (cond [(module-path-index? mpi)
(let-values ([(path relto) (module-path-index-split mpi)]) (let-values ([(path relto) (module-path-index-split mpi)])
@ -18,12 +21,16 @@
(if (module-path-index? mpi) (if (module-path-index? mpi)
(let ([mps (mpi->list mpi)]) (let ([mps (mpi->list mpi)])
(cond [(pair? mps) (cond [(pair? mps)
(apply string-append (string-join (map (lambda (x) (format "~s" x)) mps)
(format "~s" (car mps)) " <= ")]
(map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
[(null? mps) "this module"])) [(null? mps) "this module"]))
(format "~s" mpi))) (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 (provide mpi->mpi-sexpr
@ -169,7 +176,7 @@
[package (string-append (caddr m) ".plt")] [package (string-append (caddr m) ".plt")]
[version (and (cadddr m) (parse-version (cadddr m)))] [version (and (cadddr m) (parse-version (cadddr m)))]
[path (list-ref m 4)]) [path (list-ref m 4)])
`(planet ,(string-append (or path "main") ".ss") `(planet ,(string-append (or path "main") ".rkt")
(,owner ,package . ,version))))) (,owner ,package . ,version)))))
(define (parse-version str) (define (parse-version str)
@ -179,7 +186,7 @@
(define (split-mods* path) (define (split-mods* path)
(let ([mods (split-mods path)]) (let ([mods (split-mods path)])
(if (and (pair? mods) (null? (cdr mods))) (if (and (pair? mods) (null? (cdr mods)))
(append mods (list "main.ss")) (append mods (list "main.rkt"))
mods))) mods)))
(define (split-mods path [more null]) (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 racket/base
#lang scheme/base
(require scheme/promise)
(provide cursor? (provide cursor?
cursor-position cursor-position
cursor:new cursor:new
@ -24,7 +22,8 @@
cursor->list cursor->list
cursor:prefix->list cursor:prefix->list
cursor:suffix->list) cursor:suffix->list
cursor-count)
(define-struct cursor (vector count position) (define-struct cursor (vector count position)
#:mutable) #:mutable)

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

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

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

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

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

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

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

@ -1,14 +1,11 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
(rename-in unstable/class-iop racket/gui
[send/i send:] racket/list
[init-field/i init-field:]) unstable/class-iop
scheme/gui "interfaces.rkt"
scheme/list "../model/hiding-policies.rkt"
syntax/boundmap "../util/mpi.rkt"
"interfaces.ss"
"../model/hiding-policies.ss"
"../util/mpi.ss"
unstable/gui/notify) unstable/gui/notify)
(provide macro-hiding-prefs-widget%) (provide macro-hiding-prefs-widget%)
@ -16,12 +13,21 @@
(define mode:standard "Standard") (define mode:standard "Standard")
(define mode:custom "Custom ...") (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% ;; macro-hiding-prefs-widget%
(define macro-hiding-prefs-widget% (define macro-hiding-prefs-widget%
(class* object% (hiding-prefs<%>) (class* object% (hiding-prefs<%>)
(init parent) (init parent)
(init-field: (stepper widget<%>)) (init-field/i (stepper widget<%>))
(init-field config) (init-field config)
(define/public (get-policy) (define/public (get-policy)
@ -80,7 +86,7 @@
(style '(deleted)))) (style '(deleted))))
(define/private (get-mode) (define/private (get-mode)
(send: config config<%> get-macro-hiding-mode)) (send/i config config<%> get-macro-hiding-mode))
(define/private (macro-hiding-enabled?) (define/private (macro-hiding-enabled?)
(let ([mode (get-mode)]) (let ([mode (get-mode)])
@ -90,7 +96,7 @@
(define/private (ensure-custom-mode) (define/private (ensure-custom-mode)
(unless (equal? (get-mode) mode:custom) (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) (define/private (update-visibility)
(let ([customizing (equal? (get-mode) mode:custom)]) (let ([customizing (equal? (get-mode) mode:custom)])
@ -105,10 +111,10 @@
(list customize-panel) (list customize-panel)
null)))))) null))))))
(send: config config<%> listen-macro-hiding-mode (send/i config config<%> listen-macro-hiding-mode
(lambda (value) (lambda (value)
(update-visibility) (update-visibility)
(force-refresh))) (force-refresh)))
(define box:hiding (define box:hiding
(new check-box% (new check-box%
@ -176,11 +182,11 @@
;; refresh : -> void ;; refresh : -> void
(define/public (refresh) (define/public (refresh)
(when (macro-hiding-enabled?) (when (macro-hiding-enabled?)
(send: stepper widget<%> refresh/resynth))) (send/i stepper widget<%> refresh/resynth)))
;; force-refresh : -> void ;; force-refresh : -> void
(define/private (force-refresh) (define/private (force-refresh)
(send: stepper widget<%> refresh/resynth)) (send/i stepper widget<%> refresh/resynth))
;; set-syntax : syntax/#f -> void ;; set-syntax : syntax/#f -> void
(define/public (set-syntax lstx) (define/public (set-syntax lstx)
@ -255,11 +261,13 @@
(match condition (match condition
[`(free=? ,id) [`(free=? ,id)
(let ([b (identifier-binding id)]) (let ([b (identifier-binding id)])
(or #;(identifier->string id) (or #| (identifier->string id) |#
(cond [(list? b) (cond [(list? b)
(let ([mod (caddr b)] (let ([mod (caddr b)]
[name (cadddr 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 [else
(symbol->string (syntax-e id))])))] (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 (require unstable/class-iop
(prefix-in sb: "../syntax-browser/interfaces.ss")) (prefix-in sb: "../syntax-browser/interfaces.rkt"))
(provide (all-defined-out)) (provide (all-defined-out))
(define-interface config<%> (sb:config<%>) (define-interface config<%> (sb:config<%>)
@ -62,6 +62,7 @@
(get-raw-deriv (get-raw-deriv
get-deriv-hidden? get-deriv-hidden?
get-step-index get-step-index
get-step-count
invalidate-synth! invalidate-synth!
invalidate-steps! invalidate-steps!

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

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

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

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

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

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

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

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

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

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

1
collects/unstable/find.rkt
View File

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