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

macro-stepper: replaced {scheme -> racket}, {*.ss -> *.rkt}, etc

Browse Source 
original commit: efc03566055f549de2a9bf32a402185f66c14a64
This commit is contained in:
Ryan Culpepper 2010-06-30 16:31:48 -06:00
parent 9cb5f4756d
commit 79f7ee3048
54 changed files with 611 additions and 1044 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

3
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:

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

5
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

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

21
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

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

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

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

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require "deriv.ss" (require "deriv.rkt"
"deriv-util.ss") "deriv-util.rkt")
(provide (struct-out protostep) (provide (struct-out protostep)
(struct-out step) (struct-out step)
(struct-out misstep) (struct-out misstep)

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)

18
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
@ -65,7 +63,7 @@
(listen-secondary-partition (listen-secondary-partition
(lambda (p) (lambda (p)
(for ([d displays]) (for ([d displays])
(send: d display<%> refresh)))) (send/i d display<%> refresh))))
(super-new))) (super-new)))
(define controller% (define controller%

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

@ -1,16 +1,14 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/gui racket/gui
scheme/list racket/list
racket/block
framework framework
(rename-in unstable/class-iop unstable/class-iop
[send/i send:] "pretty-printer.rkt"
[init-field/i init-field:]) "interfaces.rkt"
(only-in mzlib/etc begin-with-definitions) "prefs.rkt"
"pretty-printer.ss" "util.rkt")
"interfaces.ss"
"prefs.ss"
"util.ss")
(provide print-syntax-to-editor (provide print-syntax-to-editor
code-style) code-style)
@ -27,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))
@ -56,7 +54,7 @@
;; 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
@ -64,7 +62,7 @@
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))
@ -78,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)])
@ -91,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)
@ -111,7 +109,7 @@
(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-partition-styles selected-syntax)
(apply-selection-styles selected-syntax)) (apply-selection-styles selected-syntax))
@ -162,13 +160,13 @@
(list->vector (list->vector
(map color-style (map color-style
(map translate-color (map translate-color
(send: config config<%> get-colors))))) (send/i config config<%> get-colors)))))
(define overflow-style (color-style (translate-color "darkgray"))) (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))
@ -184,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
@ -197,7 +195,7 @@
;; 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)))))
@ -207,23 +205,23 @@
(define/private (apply-secondary-partition-styles selected-syntax) (define/private (apply-secondary-partition-styles selected-syntax)
(when (identifier? selected-syntax) (when (identifier? selected-syntax)
(let ([partition (let ([partition
(send: controller secondary-partition<%> (send/i controller secondary-partition<%>
get-secondary-partition)]) get-secondary-partition)])
(when partition (when partition
(for ([id (send: range range<%> get-identifier-list)]) (for ([id (send/i range range<%> get-identifier-list)])
(when (send: partition partition<%> (when (send/i partition partition<%>
same-partition? selected-syntax id) same-partition? 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
@ -238,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)])

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)

14
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")
#| #|

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

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%

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

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

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

@ -1,7 +1,7 @@
#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%

21
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
@ -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

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

@ -1,12 +1,11 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/gui racket/gui
framework framework
(rename-in unstable/class-iop unstable/class-iop
[send/i send:]) "interfaces.rkt"
"interfaces.ss" "util.rkt"
"util.ss" "../util/mpi.rkt"
"../util/mpi.ss"
"../util/stxobj.rkt") "../util/stxobj.rkt")
(provide properties-view% (provide properties-view%
properties-snip%) properties-snip%)
@ -44,7 +43,7 @@
(field (text (new color-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)))

27
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,7 +144,7 @@
(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)
@ -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)

71
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%
@ -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

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

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/match (require racket/match
scheme/string) racket/string)
(provide mpi->list (provide mpi->list
mpi->string mpi->string
@ -176,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)
@ -186,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])

2
collects/macro-debugger/util/stxobj.rkt
View File

@ -1,4 +1,4 @@
#lang racket #lang racket/base
(require (rename-in racket/contract [-> c:->]) (require (rename-in racket/contract [-> c:->])
ffi/unsafe) ffi/unsafe)

4
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

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

31
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%)
@ -30,7 +27,7 @@ TODO
(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)
@ -89,7 +86,7 @@ TODO
(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)])
@ -99,7 +96,7 @@ TODO
(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)])
@ -114,7 +111,7 @@ TODO
(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)))
@ -185,11 +182,11 @@ TODO
;; 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)

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

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

97
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")))
@ -98,7 +93,7 @@
#: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))
@ -108,7 +103,7 @@
#: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
@ -122,7 +117,7 @@
(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)
@ -152,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)))
@ -179,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
@ -220,12 +215,12 @@
(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)))
@ -235,11 +230,11 @@
(define state (protostep-s1 step)) (define state (protostep-s1 step))
(for ([content (in-list (remarkstep-contents step))]) (for ([content (in-list (remarkstep-contents step))])
(cond [(string? content) (cond [(string? content)
(send*: sbview sb:syntax-browser<%> (send*/i sbview sb:syntax-browser<%>
(add-text content) (add-text content)
(add-text "\n"))] (add-text "\n"))]
[(syntax? content) [(syntax? content)
(send*: sbview sb:syntax-browser<%> (send*/i sbview sb:syntax-browser<%>
(add-syntax content (add-syntax content
#:binders (or (state-binders state) null) #:binders (or (state-binders state) null)
#:definites (or (state-uses state) null) #:definites (or (state-uses state) null)
@ -250,9 +245,9 @@
;; 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
@ -275,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%
@ -287,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%

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

@ -1,29 +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"
"hiding-panel.ss" "../model/deriv-util.rkt"
"term-record.ss" "../model/trace.rkt"
"step-display.ss" "../model/reductions.rkt"
(prefix-in sb: "../syntax-browser/interfaces.ss") "../model/steps.rkt"
"../model/deriv.ss" "cursor.rkt"
"../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%
@ -36,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
@ -69,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)
@ -87,16 +82,16 @@
(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)
@ -105,7 +100,7 @@
(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)))
@ -128,28 +123,28 @@
(alignment '(left center)) (alignment '(left center))
(style '(deleted)))) (style '(deleted))))
(define: sbview sb:syntax-browser<%> (define/i 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?
@ -251,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))
@ -290,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)
@ -303,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)
@ -313,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
@ -337,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)))
@ -375,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))
@ -394,11 +389,11 @@
;; refresh : -> void ;; refresh : -> void
(define/public (refresh) (define/public (refresh)
(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 "") (send nav:step-count set-label "")
(let ([term (focused-term)]) (let ([term (focused-term)])
(when term (when term
(let ([step-count (send: term term-record<%> get-step-count)]) (let ([step-count (send/i term term-record<%> get-step-count)])
(when step-count (when step-count
;; +1 for end of expansion "step" ;; +1 for end of expansion "step"
(send nav:step-count set-label (format "of ~s" (add1 step-count))))))) (send nav:step-count set-label (format "of ~s" (add1 step-count)))))))
@ -409,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
@ -418,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)
)) ))

83
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))))
@ -280,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
@ -303,9 +298,9 @@
(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)))]
@ -314,12 +309,12 @@
;; 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))