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

Syncing up here as well.

Browse Source 
svn: r13118
This commit is contained in:
Stevie Strickland 2009-01-14 18:27:06 +00:00
commit 5ac3135cd6
192 changed files with 1370 additions and 963 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/2htdp/test/world0-stops.ss
View File

@ -2,4 +2,4 @@
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp")))))
(big-bang 0 (stop-when zero?) (on-tick add1))
(big-bang 0 (stop-when zero?) (on-tick add1))

2
collects/2htdp/universe.ss
View File

@ -309,4 +309,4 @@
(on-new nu)
(on-msg process)
#;
(on-tick (lambda (u x) (printf "hello!\n") (list u)) 1)))
(on-tick (lambda (u x) (printf "hello!\n") (list u)) 1)))

2
collects/drscheme/private/insert-large-letters.ss
View File

@ -195,4 +195,4 @@
(send bdc set-bitmap #f)
bitmap)
;(make-large-letters-dialog ";" #\; #f)
;(make-large-letters-dialog ";" #\; #f)

2
collects/framework/private/comment-box.ss
View File

@ -122,4 +122,4 @@
(make-special-comment "comment"))
(super-instantiate ())
(inherit set-snipclass)
(set-snipclass snipclass))))
(set-snipclass snipclass))))

2
collects/framework/private/editor.ss
View File

@ -158,7 +158,7 @@
(inherit refresh-delayed?
get-canvas
get-max-width get-admin)
get-admin)
(define/augment (can-save-file? filename format)
(and (if (equal? filename (get-filename))

2
collects/framework/private/search.ss
View File

@ -96,4 +96,4 @@
(if (not embedded-pos)
(next-loop)
(values embedded embedded-pos)))]
[else (next-loop)])))))))
[else (next-loop)])))))))

2
collects/framework/private/sig.ss
View File

@ -465,4 +465,4 @@
(open (prefix frame: frame^))
(open (prefix handler: handler^))
(open (prefix scheme: scheme^))
(open (prefix main: main^))))
(open (prefix main: main^))))

2
collects/games/chat-noir/info.ss
View File

@ -3,4 +3,4 @@
(define game "chat-noir-unit.ss")
(define game-set "Puzzle Games")
(define compile-omit-files '("chat-noir.ss"))
(define name "Chat Noir")
(define name "Chat Noir")

2
collects/htdp/Test/hangman-error.ss
View File

@ -11,4 +11,4 @@
(start 200 200)
(check-error (hangman-list reveal-list draw-next-part)
"draw-next-part: result of type <boolean> expected, given: #<void>")
"draw-next-part: result of type <boolean> expected, given: #<void>")

8
collects/lang/private/beginner-funs.ss
View File

@ -32,18 +32,18 @@
((beginner-* *) (num num num ... -> num)
"to compute the product of all of the input numbers")
((beginner-/ /) (num num num ... -> num)
"to divide the first by the second (and all following) number(s);"
"to divide the first by the second (and all following) number(s); try (/ 3 4) and (/ 3 2 2)"
" only the first number can be zero.")
(max (real real ... -> real)
"to determine the largest number")
(min (real real ... -> real)
"to determine the smallest number")
(quotient (int int -> int)
"to compute the quotient of two integers")
"to divide the first integer into the second; try (quotient 3 4) and (quotient 4 3)")
(remainder (int int -> int)
"to compute the remainder of dividing the first by the second integer")
"to determine the remainder of dividing the first by the second integer")
(modulo (int int -> int)
"to compute first number modulo second number")
"to find the remainder of the division of the first number by the second; try (modulo 4 3) (modulo 4 -3)")
(sqr (num -> num)
"to compute the square of a number")
(sqrt (num -> num)

2
collects/macro-debugger/model/hiding-policies.ss
View File

@ -437,4 +437,4 @@
(define (lib-module-path? mp)
(or (symbol? mp)
(and (pair? mp) (memq (car mp) '(lib planet)))))
|#
|#

14
collects/macro-debugger/stxclass/private/lib.ss
View File

@ -69,6 +69,20 @@
#:pattern 'static
#:reason "not an identifier"))))
(define-basic-syntax-class (static-of name pred)
([value 0])
(lambda (x name pred)
(let/ec escape
(define (bad)
(escape (fail-sc x
#:pattern 'name
#:reason (format "not bound as ~a" name))))
(if (identifier? x)
(let ([value (syntax-local-value x bad)])
(unless (pred value) (bad))
(list value))
(bad)))))
(define-basic-syntax-class struct-name
([descriptor 0]
[constructor 0]

2
collects/macro-debugger/stxclass/private/parse.ss
View File

@ -74,7 +74,7 @@
(with-syntax ([k k] [x x] [p p] [reason reason]
[fc-expr (frontier->expr fc)])
#`(let ([failcontext fc-expr])
(printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext)
#;(printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext)
(k x p 'reason failcontext))))
;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)

4
collects/macro-debugger/stxclass/private/rep.ss
View File

@ -185,7 +185,9 @@
[args (cdr p)])
(unless (equal? (length (sc-inputs stxclass)) (length args))
(raise-syntax-error 'syntax-class
"too few arguments for syntax class"
(format "too few arguments for syntax class ~a (expected ~s)"
(sc-name stxclass)
(length (sc-inputs stxclass)))
id))
(values id stxclass args (ssc? stxclass))))]
[else (values id #f null #f)]))

1
collects/macro-debugger/stxclass/private/util.ss
View File

@ -214,6 +214,7 @@
[_
(loop (stx-cdr x) (cons ee ex) #t)]))]
[(stx-null? x)
(internal-definition-context-seal intdef)
(reverse ex)]))))

16
collects/macro-debugger/syntax-browser/controller.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
"interfaces.ss"
"partition.ss"
"../util/notify.ss")
@ -31,7 +32,7 @@
(super-new)
(listen-selected-syntax
(lambda (new-value)
(for-each (lambda (display) (send display refresh))
(for-each (lambda (display) (send: display display<%> refresh))
displays)))))
;; mark-manager-mixin
@ -62,14 +63,15 @@
(new partition% (relation (cdr name+proc)))))))
(listen-secondary-partition
(lambda (p)
(for-each (lambda (d) (send d refresh))
(for-each (lambda (d) (send: d display<%> refresh))
displays)))
(super-new)))
(define controller%
(class (secondary-partition-mixin
(selection-manager-mixin
(mark-manager-mixin
(displays-manager-mixin
object%))))
(class* (secondary-partition-mixin
(selection-manager-mixin
(mark-manager-mixin
(displays-manager-mixin
object%))))
(controller<%>)
(super-new)))

45
collects/macro-debugger/syntax-browser/display.ss
View File

@ -3,6 +3,7 @@
(require scheme/class
scheme/gui
scheme/match
macro-debugger/util/class-iop
"pretty-printer.ss"
"interfaces.ss"
"util.ss")
@ -17,7 +18,7 @@
(define output-port (open-output-string/count-lines))
(define range
(pretty-print-syntax stx output-port
(send controller get-primary-partition)
(send: controller controller<%> get-primary-partition)
(send config get-colors)
(send config get-suffix-option)
columns))
@ -42,13 +43,14 @@
;; add-clickbacks : text% range% controller<%> number -> void
(define (add-clickbacks text range controller insertion-point)
(for ([range (send range all-ranges)])
(for ([range (send: range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text set-clickback (+ insertion-point start) (+ insertion-point end)
(lambda (_1 _2 _3)
(send controller set-selected-syntax stx))))))
(send: controller selection-manager<%>
set-selected-syntax stx))))))
;; set-standard-font : text% config number number -> void
(define (set-standard-font text config start end)
@ -81,7 +83,9 @@
(begin-edit-sequence)
(change-style unhighlight-d start-position end-position))
(apply-extra-styles)
(let ([selected-syntax (send controller get-selected-syntax)])
(let ([selected-syntax
(send: controller selection-manager<%>
get-selected-syntax)])
(apply-secondary-partition-styles selected-syntax)
(apply-selection-styles selected-syntax))
(send* text
@ -126,9 +130,11 @@
(let ([delta (new style-delta%)])
(send delta set-delta-foreground color)
delta))
(define color-styles (list->vector (map color-style (send config get-colors))))
(define color-styles
(list->vector (map color-style (send config get-colors))))
(define overflow-style (color-style "darkgray"))
(define color-partition (send controller get-primary-partition))
(define color-partition
(send: controller mark-manager<%> get-primary-partition))
(define offset start-position)
(for-each
(lambda (range)
@ -139,12 +145,12 @@
(primary-style stx color-partition color-styles overflow-style)
(+ offset start)
(+ offset end))))
(send range all-ranges)))
(send: range range<%> all-ranges)))
;; primary-style : syntax partition (vector-of style-delta%) style-delta%
;; -> style-delta%
(define/private (primary-style stx partition color-vector overflow)
(let ([n (send partition get-partition stx)])
(let ([n (send: partition partition<%> get-partition stx)])
(cond [(< n (vector-length color-vector))
(vector-ref color-vector n)]
[else
@ -157,7 +163,7 @@
;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles)
(for ([(stx style-deltas) extra-styles])
(for ([r (send range get-ranges stx)])
(for ([r (send: range range<%> get-ranges stx)])
(for ([style-delta style-deltas])
(restyle-range r style-delta)))))
@ -166,23 +172,25 @@
;; in the same partition in blue.
(define/private (apply-secondary-partition-styles selected-syntax)
(when (identifier? selected-syntax)
(let ([partition (send controller get-secondary-partition)])
(let ([partition
(send: controller secondary-partition<%>
get-secondary-partition)])
(when partition
(for-each (lambda (id)
(when (send partition same-partition? selected-syntax id)
(draw-secondary-connection id)))
(send range get-identifier-list))))))
(for ([id (send: range range<%> get-identifier-list)])
(when (send: partition partition<%>
same-partition? selected-syntax id)
(draw-secondary-connection id)))))))
;; apply-selection-styles : syntax -> void
;; Styles subterms eq to the selected syntax
(define/private (apply-selection-styles selected-syntax)
(let ([rs (send range get-ranges selected-syntax)])
(for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
(for ([r (send: range range<%> get-ranges selected-syntax)])
(restyle-range r select-highlight-d)))
;; draw-secondary-connection : syntax -> void
(define/private (draw-secondary-connection stx2)
(let ([rs (send range get-ranges stx2)])
(for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
(for ([r (send range get-ranges stx2)])
(restyle-range r select-sub-highlight-d)))
;; restyle-range : (cons num num) style-delta% -> void
(define/private (restyle-range r style)
@ -258,4 +266,3 @@
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
(define unhighlight-d (highlight-style-delta "white" #f))

8
collects/macro-debugger/syntax-browser/frame.ss
View File

@ -1,4 +1,3 @@
#lang scheme/base
(require scheme/class
scheme/gui
@ -20,10 +19,9 @@
;; browse-syntaxes : (list-of syntax) -> void
(define (browse-syntaxes stxs)
(let ((w (make-syntax-browser)))
(for-each (lambda (stx)
(send w add-syntax stx)
(send w add-separator))
stxs)))
(for ([stx stxs])
(send w add-syntax stx)
(send w add-separator))))
;; make-syntax-browser : -> syntax-browser<%>
(define (make-syntax-browser)

213
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -1,165 +1,156 @@
#lang scheme/base
(require scheme/class)
(require scheme/class
macro-debugger/util/class-iop)
(provide (all-defined-out))
;; displays-manager<%>
(define displays-manager<%>
(interface ()
;; add-syntax-display : display<%> -> void
add-syntax-display
(define-interface displays-manager<%> ()
(;; add-syntax-display : display<%> -> void
add-syntax-display
;; remove-all-syntax-displays : -> void
remove-all-syntax-displays))
;; remove-all-syntax-displays : -> void
remove-all-syntax-displays))
;; selection-manager<%>
(define selection-manager<%>
(interface ()
;; selected-syntax : syntax/#f
set-selected-syntax
get-selected-syntax
listen-selected-syntax
))
(define-interface selection-manager<%> ()
(;; selected-syntax : syntax/#f
set-selected-syntax
get-selected-syntax
listen-selected-syntax))
;; mark-manager<%>
;; Manages marks, mappings from marks to colors
(define mark-manager<%>
(interface ()
;; get-primary-partition : -> partition
get-primary-partition))
(define-interface mark-manager<%> ()
(;; get-primary-partition : -> partition
get-primary-partition
;; reset-primary-partition : -> void
reset-primary-partition))
;; secondary-partition<%>
(define secondary-partition<%>
(interface (displays-manager<%>)
;; get-secondary-partition : -> partition<%>
get-secondary-partition
(define-interface secondary-partition<%> ()
(;; get-secondary-partition : -> partition<%>
get-secondary-partition
;; set-secondary-partition : partition<%> -> void
set-secondary-partition
;; set-secondary-partition : partition<%> -> void
set-secondary-partition
;; listen-secondary-partition : (partition<%> -> void) -> void
listen-secondary-partition
;; listen-secondary-partition : (partition<%> -> void) -> void
listen-secondary-partition
;; get-identifier=? : -> (cons string procedure)
get-identifier=?
;; get-identifier=? : -> (cons string procedure)
get-identifier=?
;; set-identifier=? : (cons string procedure) -> void
set-identifier=?
;; set-identifier=? : (cons string procedure) -> void
set-identifier=?
;; listen-identifier=? : ((cons string procedure) -> void) -> void
listen-identifier=?))
;; listen-identifier=? : ((cons string procedure) -> void) -> void
listen-identifier=?))
;; controller<%>
(define controller<%>
(interface (displays-manager<%>
selection-manager<%>
mark-manager<%>
secondary-partition<%>)))
(define-interface controller<%> (displays-manager<%>
selection-manager<%>
mark-manager<%>
secondary-partition<%>)
())
;; host<%>
(define host<%>
(interface ()
;; get-controller : -> controller<%>
get-controller
;; add-keymap : text snip
add-keymap
))
(define-interface host<%> ()
(;; get-controller : -> controller<%>
get-controller
;; add-keymap : text snip
add-keymap))
;; display<%>
(define display<%>
(interface ()
;; refresh : -> void
refresh
(define-interface display<%> ()
(;; refresh : -> void
refresh
;; highlight-syntaxes : (list-of syntax) color -> void
highlight-syntaxes
;; highlight-syntaxes : (list-of syntax) color -> void
highlight-syntaxes
;; get-start-position : -> number
get-start-position
;; underline-syntaxes : (listof syntax) -> void
underline-syntaxes
;; get-end-position : -> number
get-end-position
;; get-start-position : -> number
get-start-position
;; get-range : -> range<%>
get-range))
;; get-end-position : -> number
get-end-position
;; get-range : -> range<%>
get-range))
;; range<%>
(define range<%>
(interface ()
;; get-ranges : datum -> (list-of (cons number number))
get-ranges
(define-interface range<%> ()
(;; get-ranges : datum -> (list-of (cons number number))
get-ranges
;; all-ranges : (list-of Range)
;; Sorted outermost-first
all-ranges
;; all-ranges : (list-of Range)
;; Sorted outermost-first
all-ranges
;; get-identifier-list : (list-of identifier)
get-identifier-list))
;; get-identifier-list : (list-of identifier)
get-identifier-list))
;; A Range is (make-range datum number number)
(define-struct range (obj start end))
;; syntax-prefs<%>
(define syntax-prefs<%>
(interface ()
pref:width
pref:height
pref:props-percentage
pref:props-shown?))
(define-interface syntax-prefs<%> ()
(pref:width
pref:height
pref:props-percentage
pref:props-shown?))
;; widget-hooks<%>
(define widget-hooks<%>
(interface ()
;; setup-keymap : -> void
setup-keymap
(define-interface widget-hooks<%> ()
(;; setup-keymap : -> void
setup-keymap
;; shutdown : -> void
shutdown
))
;; shutdown : -> void
shutdown))
;; keymap-hooks<%>
(define keymap-hooks<%>
(interface ()
;; make-context-menu : -> context-menu<%>
make-context-menu
(define-interface keymap-hooks<%> ()
(;; make-context-menu : -> context-menu<%>
make-context-menu
;; get-context-menu% : -> class
get-context-menu%))
;; get-context-menu% : -> class
get-context-menu%))
;; context-menu-hooks<%>
(define context-menu-hooks<%>
(interface ()
add-edit-items
after-edit-items
add-selection-items
after-selection-items
add-partition-items
after-partition-items))
(define-interface context-menu-hooks<%> ()
(add-edit-items
after-edit-items
add-selection-items
after-selection-items
add-partition-items
after-partition-items))
;;----------
;; Convenience widget, specialized for displaying stx and not much else
(define syntax-browser<%>
(interface ()
add-syntax
add-text
add-separator
erase-all
select-syntax
get-text
))
(define-interface syntax-browser<%> ()
(add-syntax
add-text
add-error-text
add-clickback
add-separator
erase-all
get-text))
(define partition<%>
(interface ()
;; get-partition : any -> number
get-partition
(define-interface partition<%> ()
(;; get-partition : any -> number
get-partition
;; same-partition? : any any -> number
same-partition?
;; same-partition? : any any -> number
same-partition?
;; count : -> number
count))
;; count : -> number
count))

1
collects/macro-debugger/syntax-browser/keymap.ss
View File

@ -1,4 +1,3 @@
#lang scheme/base
(require scheme/class
scheme/gui

9
collects/macro-debugger/syntax-browser/properties.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/class
scheme/gui
macro-debugger/util/class-iop
"interfaces.ss"
"util.ss"
"../util/mpi.ss")
@ -24,10 +25,10 @@
(field (text (new text%)))
(field (pdisplayer (new properties-displayer% (text text))))
(send controller listen-selected-syntax
(lambda (stx)
(set! selected-syntax stx)
(refresh)))
(send: controller selection-manager<%> listen-selected-syntax
(lambda (stx)
(set! selected-syntax stx)
(refresh)))
(super-new)
;; get-mode : -> symbol

22
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -6,6 +6,7 @@
scheme/list
scheme/match
syntax/boundmap
macro-debugger/util/class-iop
"interfaces.ss"
"controller.ss"
"display.ss"
@ -20,7 +21,7 @@
;; widget%
;; A syntax widget creates its own syntax-controller.
(define widget%
(class* object% (widget-hooks<%>)
(class* object% (syntax-browser<%> widget-hooks<%>)
(init parent)
(init-field config)
@ -119,7 +120,8 @@
(let ([display (internal-add-syntax stx)]
[definite-table (make-hasheq)])
(for-each (lambda (hi-stxs hi-color)
(send display highlight-syntaxes hi-stxs hi-color))
(send: display display<%>
highlight-syntaxes hi-stxs hi-color))
hi-stxss
hi-colors)
(for ([definite definites])
@ -128,20 +130,20 @@
(for ([shifted-definite (hash-ref shift-table definite null)])
(hash-set! definite-table shifted-definite #t))))
(when alpha-table
(let ([range (send display get-range)]
[start (send display get-start-position)])
(let ([range (send: display display<%> get-range)]
[start (send: display display<%> get-start-position)])
(let* ([binders0
(module-identifier-mapping-map alpha-table (lambda (k v) k))]
[binders
(apply append (map get-binders binders0))])
(send display underline-syntaxes binders))
(for ([id (send range get-identifier-list)])
(send: display display<%> underline-syntaxes binders))
(for ([id (send: range range<%> get-identifier-list)])
(define definite? (hash-ref definite-table id #f))
(when #f ;; DISABLED
(add-binding-billboard start range id definite?))
(for ([binder (get-binders id)])
(for ([binder-r (send range get-ranges binder)])
(for ([id-r (send range get-ranges id)])
(for ([binder-r (send: range range<%> get-ranges binder)])
(for ([id-r (send: range range<%> get-ranges id)])
(add-binding-arrow start binder-r id-r definite?)))))))
(void)))
@ -169,7 +171,7 @@
(+ start (cdr id-r))
(string-append "from " (mpi->string src-mod))
(if definite? "blue" "purple")))
(send range get-ranges id))]
(send: range range<%> get-ranges id))]
[_ (void)]))
(define/public (add-separator)
@ -182,7 +184,7 @@
(with-unlock -text
(send -text erase)
(send -text delete-all-drawings))
(send controller remove-all-syntax-displays))
(send: controller displays-manager<%> remove-all-syntax-displays))
(define/public (get-text) -text)

73
collects/macro-debugger/util/class-ct.ss Normal file
View File

@ -0,0 +1,73 @@
#lang scheme/base
(require (for-template scheme/base
scheme/class)
macro-debugger/stxclass/stxclass)
(provide static-interface?
make-static-interface
static-interface-dynamic
static-interface-members
make-checked-binding
checked-binding?
checked-binding-dynamic
checked-binding-iface
checked-binding
static-interface)
(define-struct static-interface (dynamic members)
#:omit-define-syntaxes
#:property prop:procedure
(lambda (self stx)
(syntax-case stx ()
[(ifname . args)
(datum->syntax stx (cons #'(#%expression ifname) #'args) stx)]
[ifname
(identifier? #'ifname)
(static-interface-dynamic self)])))
(define-struct raw-checked-binding (dynamic iface)
#:omit-define-syntaxes
#:property prop:procedure
(lambda (self stx)
(syntax-case stx (set!)
[(set! var expr)
#`(let ([newval expr])
(unless (is-a? newval #,(static-interface-dynamic
(raw-checked-binding-iface self)))
(error 'check "interface check failed on: ~e" newval))
(set! #,(raw-checked-binding-dynamic self) newval))]
[(var . args)
(datum->syntax stx (cons #'(#%expression var) #'args) stx)]
[var
(identifier? #'var)
(raw-checked-binding-dynamic self)]
[else
(raise-syntax-error #f "oops" stx)])))
(define (make-checked-binding dynamic iface)
(make-set!-transformer
(make-raw-checked-binding dynamic iface)))
(define (checked-binding? x)
(and (set!-transformer? x)
(raw-checked-binding? (set!-transformer-procedure x))))
(define (checked-binding-dynamic x)
(raw-checked-binding-dynamic (set!-transformer-procedure x)))
(define (checked-binding-iface x)
(raw-checked-binding-iface (set!-transformer-procedure x)))
;; Syntax
(define-syntax-class static-interface
(pattern x
#:declare x (static-of 'static-interface static-interface?)
#:with value #'x.value))
(define-syntax-class checked-binding
(pattern x
#:declare x (static-of 'checked-binding checked-binding?)
#:with value #'x.value))

217
collects/macro-debugger/util/class-iop.ss Normal file
View File

@ -0,0 +1,217 @@
#lang scheme/base
(require scheme/class
(for-syntax scheme/base
macro-debugger/stxclass/stxclass
"class-ct.ss"))
(provide define-interface
define-interface/dynamic
send:
send*:
send/apply:
define:
lambda:
init:
init-field:
init-private:)
;; Configuration
(define-for-syntax warn-on-dynamic-interfaces? #f)
(define-for-syntax warn-on-dynamic-object-check-generation? #f)
(define-for-syntax define-dotted-names #f)
;; define-interface SYNTAX
;; (define-interface NAME (IDENTIFIER ...))
;; Defines NAME as an interface.
(define-syntax (define-interface stx)
(syntax-parse stx
[(_ name:id (super:static-interface ...) (mname:id ...))
(with-syntax ([((super-method ...) ...)
(map static-interface-members
(syntax->datum #'(super.value ...)))])
#'(define-interface/dynamic name
(let ([name (interface (super ...) mname ...)]) name)
(super-method ... ... mname ...)))]))
;; define-interface/dynamic SYNTAX
;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
;; Defines NAME as a static interface containing the names listed.
;; The EXPR is used as the dynamic componenent of the interface, and
;; it should contain a superset of the names listed.
(define-syntax (define-interface/dynamic stx)
(syntax-parse stx
[(_ name:id dynamic-interface:expr (mname:id ...))
(with-syntax ([(dynamic-name) (generate-temporaries #'(name))])
#'(begin (define dynamic-name
(let ([dynamic-name dynamic-interface])
(for-each
(lambda (m)
(unless (method-in-interface? m dynamic-name)
(error 'name "dynamic interface missing method '~s'" m)))
'(mname ...))
dynamic-name))
(define-syntax name
(make-static-interface #'dynamic-name '(mname ...)))))]))
;; Helper
(begin-for-syntax
(define (check-method-in-interface for-whom method si)
(unless (member (syntax-e method) (static-interface-members si))
(raise-syntax-error for-whom
"method not in static interface"
method))))
;; Checked send
(define-syntax (send: stx)
(syntax-parse stx
[(send: obj:expr iface:static-interface method:id . args)
(begin (check-method-in-interface 'send: #'method #'iface.value)
(syntax/loc stx
(send (check-object<:interface send: obj iface)
method . args)))]))
(define-syntax (send*: stx)
(syntax-parse stx
[(send*: obj:expr iface:static-interface (method:id . args) ...)
(begin (for ([method (syntax->list #'(method ...))])
(check-method-in-interface 'send*: method #'iface.value))
(syntax/loc stx
(send* (check-object<:interface send*: obj iface)
(method . args) ...)))]))
(define-syntax (send/apply: stx)
(syntax-parse stx
[(send/apply: obj:expr iface:static-interface method:id . args)
(begin (check-method-in-interface 'send/apply: #'method #'iface.value)
(syntax/loc stx
(send/apply (check-object<:interface send/apply obj iface)
method . args)))]))
;;
;; check-object<:interface SYNTAX
(define-syntax (check-object<:interface stx)
(syntax-parse stx
[(_ for-whom obj:checked-binding iface:static-interface)
(if (eq? (checked-binding-iface #'obj.value) #'iface.value)
#'obj
(syntax/loc stx
(check-object<:interface for-whom
(#%expression obj)
(#%expression iface))))]
[(_ for-whom obj:expr iface:expr)
(begin
(when warn-on-dynamic-object-check-generation?
(printf "dynamic object check: ~s,~s~n"
(syntax-source #'obj)
(syntax-line #'obj)))
#'(dynamic:check-object<:interface 'for-whom obj iface))]))
(define (dynamic:check-object<:interface for-whom obj iface)
(unless (is-a? obj iface)
(error for-whom "interface check failed on: ~e" obj))
obj)
;;
(define-syntax (define: stx)
(syntax-parse stx
[(_ name:id iface:static-interface expr)
(let ([si #'iface.value])
(with-syntax ([(name-internal) (generate-temporaries #'(name))]
[(method ...) (static-interface-members si)]
[(name.method ...)
(map (lambda (m)
(datum->syntax #'name
(string->symbol (format "~a.~a" (syntax-e #'name) m))))
(static-interface-members si))])
#`(begin (define name-internal
(check-object<:interface define: expr iface))
(define-syntax name
(make-checked-binding
#'name-internal
(syntax-local-value #'iface)))
#,(if define-dotted-names
#'(begin
(define-syntax name.method
(syntax-rules ()
[(name.method . args)
(send: name iface method . args)]))
...)
#'(begin)))))]
[(_ (f:id . args) . body)
#'(define f (lambda: args . body))]))
(define-syntax (lambda: stx)
;; FIXME: rewrite as stxclass
(define (arg->define stx temp)
(syntax-case stx ()
[(arg : iface)
(and (identifier? #'arg)
(eq? ': (syntax-e #':)))
#`(define: arg iface #,temp)]
[arg
(identifier? #'arg)
#`(define-syntax arg (make-rename-transformer #'#,temp))]))
(syntax-parse stx
[(_ (arg ...) . body)
(let ([temporaries (generate-temporaries #'(arg ...))])
(with-syntax ([(temp ...) temporaries]
[(checked-definition ...)
(map arg->define
(syntax->list #'(arg ...))
temporaries)])
#'(lambda (temp ...)
(let ()
checked-definition ...
(let () . body)))))]))
;; FIXME: unsafe due to mutation
(define-syntax (init-field: stx)
(syntax-parse stx
[(_ (name:id iface:static-interface) ...)
#'(begin (init1: init-field name iface) ...)]))
(define-syntax (init: stx)
(syntax-parse stx
[(_ (name:id iface:static-interface) ...)
#'(begin (init1: init name iface) ...)]))
(define-syntax (init1: stx)
(syntax-parse stx
[(_ init name:id iface:static-interface)
(with-syntax ([(name-internal) (generate-temporaries #'(name))])
#'(begin (init ((name-internal name)))
(void (check-object<:interface init: name-internal iface))
(define-syntax name
(make-checked-binding
#'name-internal
(syntax-local-value #'iface)))))]))
(define-syntax (init-private stx)
(syntax-parse stx
[(init-private form ...)
#'(begin (init-private1 form) ...)]))
(define-syntax (init-private1 stx)
(syntax-parse stx
[(init-private1 id:id)
(with-syntax ([(id-internal) (generate-temporaries #'(id))])
#'(begin (init (id-internal id))
(define id id-internal)))]))
(define-syntax (init-private: stx)
(syntax-parse stx
[(_ (name:id iface:static-interface) ...)
#'(begin (init-private1: name iface) ...)]))
(define-syntax (init-private1: stx)
(syntax-parse stx
[(_ name:id iface:static-interface)
(with-syntax ([(id-internal) (generate-temporaries #'(id))])
#'(begin (init (id-internal name))
(define: name iface id-internal)))]))

25
collects/macro-debugger/view/extensions.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/unit
scheme/list
scheme/match
@ -13,6 +14,7 @@
"hiding-panel.ss"
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/keymap.ss")
(prefix-in s: "../syntax-browser/interfaces.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
@ -26,7 +28,7 @@
(define stepper-keymap%
(class s:syntax-keymap%
(init-field macro-stepper)
(init-field: (macro-stepper widget<%>))
(inherit-field config
controller
the-context-menu)
@ -39,17 +41,17 @@
(super-new)
(define/public (get-hiding-panel)
(send macro-stepper get-macro-hiding-prefs))
(send: macro-stepper widget<%> get-macro-hiding-prefs))
(add-function "hiding:show-macro"
(lambda (i e)
(send* (get-hiding-panel)
(send*: (get-hiding-panel) hiding-prefs<%>
(add-show-identifier)
(refresh))))
(add-function "hiding:hide-macro"
(lambda (i e)
(send* (get-hiding-panel)
(send*: (get-hiding-panel) hiding-prefs<%>
(add-hide-identifier)
(refresh))))
@ -75,26 +77,27 @@
(send show-macro enable ?)
(send hide-macro enable ?))
(send controller listen-selected-syntax
(lambda (stx)
(enable/disable-hide/show (identifier? stx))))))
(send: controller s:controller<%> listen-selected-syntax
(lambda (stx)
(enable/disable-hide/show (identifier? stx))))))
(define stepper-syntax-widget%
(class s:widget%
(init-field macro-stepper)
(init-field: (macro-stepper widget<%>))
(inherit get-text)
(inherit-field controller)
(define/override (setup-keymap)
(new stepper-keymap%
(editor (get-text))
(config (send macro-stepper get-config))
(config (send: macro-stepper widget<%> get-config))
(controller controller)
(macro-stepper macro-stepper)))
(define/override (show-props show?)
(super show-props show?)
(send macro-stepper update/preserve-view))
(send: macro-stepper widget<%> update/preserve-view))
(super-new
(config (send macro-stepper get-config)))))
(config (send: macro-stepper widget<%> get-config)))))

36
collects/macro-debugger/view/frame.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/unit
scheme/list
scheme/file
@ -14,6 +15,7 @@
"warning.ss"
"hiding-panel.ss"
(prefix-in sb: "../syntax-browser/embed.ss")
(prefix-in sb: "../syntax-browser/interfaces.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
@ -23,7 +25,7 @@
(provide macro-stepper-frame-mixin)
(define (macro-stepper-frame-mixin base-frame%)
(class base-frame%
(class* base-frame% (stepper-frame<%>)
(init-field config)
(init-field director)
(init-field (filename #f))
@ -54,7 +56,7 @@
(define/override (on-size w h)
(send config set-width w)
(send config set-height h)
(send widget update/preserve-view))
(send: widget widget<%> update/preserve-view))
(define warning-panel
(new horizontal-panel%
@ -65,12 +67,13 @@
(define/public (get-macro-stepper-widget%)
macro-stepper-widget%)
(define widget
(define: widget widget<%>
(new (get-macro-stepper-widget%)
(parent (get-area-container))
(director director)
(config config)))
(define controller (send widget get-controller))
(define: controller sb:controller<%>
(send: widget widget<%> get-controller))
(define/public (get-widget) widget)
(define/public (get-controller) controller)
@ -112,11 +115,11 @@
(new (get-menu-item%)
(label "Duplicate stepper")
(parent file-menu)
(callback (lambda _ (send widget duplicate-stepper))))
(callback (lambda _ (send: widget widget<%> duplicate-stepper))))
(new (get-menu-item%)
(label "Duplicate stepper (current term only)")
(parent file-menu)
(callback (lambda _ (send widget show-in-new-frame)))))
(callback (lambda _ (send: widget widget<%> show-in-new-frame)))))
(menu-option/notify-box stepper-menu
"View syntax properties"
@ -133,23 +136,24 @@
(parent id-menu)
(callback
(lambda _
(send controller set-identifier=? p))))])
(send controller listen-identifier=?
(lambda (name+func)
(send this-choice check
(eq? (car name+func) (car p)))))))
(send: controller sb:controller<%> set-identifier=? p))))])
(send: controller sb:controller<%> listen-identifier=?
(lambda (name+func)
(send this-choice check
(eq? (car name+func) (car p)))))))
(sb:identifier=-choices)))
(let ([identifier=? (send config get-identifier=?)])
(when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))])
(send controller set-identifier=? p))))
(send: controller sb:controller<%> set-identifier=? p))))
(new (get-menu-item%)
(label "Clear selection")
(parent stepper-menu)
(callback
(lambda _ (send controller set-selected-syntax #f))))
(lambda _ (send: controller sb:controller<%>
set-selected-syntax #f))))
(new separator-menu-item% (parent stepper-menu))
@ -160,11 +164,11 @@
(new (get-menu-item%)
(label "Remove selected term")
(parent stepper-menu)
(callback (lambda _ (send widget remove-current-term))))
(callback (lambda _ (send: widget widget<%> remove-current-term))))
(new (get-menu-item%)
(label "Reset mark numbering")
(parent stepper-menu)
(callback (lambda _ (send widget reset-primary-partition))))
(callback (lambda _ (send: widget widget<%> reset-primary-partition))))
(let ([extras-menu
(new (get-menu%)
(label "Extra options")
@ -178,7 +182,7 @@
(if (send i is-checked?)
'always
'over-limit))
(send widget update/preserve-view))))
(send: widget widget<%> update/preserve-view))))
(menu-option/notify-box extras-menu
"Highlight redex/contractum"
(get-field highlight-foci? config))

10
collects/macro-debugger/view/hiding-panel.ss
View File

@ -1,9 +1,11 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/gui
scheme/list
syntax/boundmap
"interfaces.ss"
"../model/hiding-policies.ss"
"../util/mpi.ss"
"../util/notify.ss")
@ -16,9 +18,9 @@
;; macro-hiding-prefs-widget%
(define macro-hiding-prefs-widget%
(class object%
(class* object% (hiding-prefs<%>)
(init parent)
(init-field stepper)
(init-field: (stepper widget<%>))
(init-field config)
(define/public (get-policy)
@ -173,11 +175,11 @@
;; refresh : -> void
(define/public (refresh)
(when (macro-hiding-enabled?)
(send stepper refresh/resynth)))
(send: stepper widget<%> refresh/resynth)))
;; force-refresh : -> void
(define/private (force-refresh)
(send stepper refresh/resynth))
(send: stepper widget<%> refresh/resynth))
;; set-syntax : syntax/#f -> void
(define/public (set-syntax lstx)

109
collects/macro-debugger/view/interfaces.ss
View File

@ -1,50 +1,77 @@
#lang scheme/base
(require scheme/unit)
(require macro-debugger/util/class-iop)
(provide (all-defined-out))
;; Signatures
(define-interface widget<%> ()
(get-config
get-controller
get-macro-hiding-prefs
get-step-displayer
#;
(define-signature view^
(macro-stepper-frame%
macro-stepper-widget%
make-macro-stepper
go
go/deriv))
add-trace
add-deriv
#;
(define-signature view-base^
(base-frame%))
update/preserve-view
refresh/resynth
#;
(define-signature prefs^
(pref:width
pref:height
pref:props-shown?
pref:props-percentage
pref:macro-hiding-mode
pref:show-syntax-properties?
pref:show-hiding-panel?
pref:identifier=?
pref:show-rename-steps?
pref:highlight-foci?
pref:highlight-frontier?
pref:suppress-warnings?
pref:one-by-one?
pref:extra-navigation?
pref:debug-catch-errors?
pref:force-letrec-transformation?
reset-primary-partition
remove-current-term
duplicate-stepper
show-in-new-frame
get-preprocess-deriv
get-show-macro?
))
(define-interface stepper-frame<%> ()
(get-widget
get-controller
add-obsoleted-warning))
(define-interface hiding-prefs<%> ()
(add-show-identifier
add-hide-identifier
set-syntax
get-policy
refresh))
(define-interface step-display<%> ()
(add-syntax
add-step
add-error
add-final
add-internal-error))
(define-interface term-record<%> ()
(get-raw-deriv
get-deriv-hidden?
get-step-index
invalidate-synth!
invalidate-steps!
has-prev?
has-next?
#|
at-start?
at-end?
|#
navigate-to-start
navigate-to-end
navigate-previous
navigate-next
navigate-to
on-get-focus
on-lose-focus
display-initial-term
display-final-term
display-step
))
;; macro-stepper-config%
;; all fields are notify-box% objects
;; width
;; height
;; macro-hiding?
;; hide-primitives?
;; hide-libs?
;; show-syntax-properties?
;; show-hiding-panel?
;; show-rename-steps?
;; highlight-foci?
(define-interface director<%> ()
(add-deriv
new-stepper))

161
collects/macro-debugger/view/step-display.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/unit
scheme/list
scheme/match
@ -21,8 +22,10 @@
"../model/reductions.ss"
"../model/steps.ss"
"../util/notify.ss"
(prefix-in sb: "../syntax-browser/interfaces.ss")
"cursor.ss"
"debug-format.ss")
#;
(provide step-display%
step-display<%>)
@ -35,24 +38,6 @@
(define (prestep-term1 s) (state-term (protostep-s1 s)))
(define (poststep-term2 s) (state-term (protostep-s1 s)))
(define step-display<%>
(interface ()
;; add-syntax
add-syntax
;; add-step
add-step
;; add-error
add-error
;; add-final
add-final
;; add-internal-error
add-internal-error))
(define step-display%
(class* object% (step-display<%>)
@ -61,18 +46,18 @@
(super-new)
(define/public (add-internal-error part exn stx events)
(send sbview add-text
(if part
(format "Macro stepper error (~a)" part)
"Macro stepper error"))
(send: sbview sb:syntax-browser<%> add-text
(if part
(format "Macro stepper error (~a)" part)
"Macro stepper error"))
(when (exn? exn)
(send sbview add-text " ")
(send sbview add-clickback "[details]"
(lambda _ (show-internal-error-details exn events))))
(send sbview add-text ". ")
(when stx (send sbview add-text "Original syntax:"))
(send sbview add-text "\n")
(when stx (send sbview add-syntax stx)))
(send: sbview sb:syntax-browser<%> add-text " ")
(send: sbview sb:syntax-browser<%> add-clickback "[details]"
(lambda _ (show-internal-error-details exn events))))
(send: sbview sb:syntax-browser<%> add-text ". ")
(when stx (send: sbview sb:syntax-browser<%> add-text "Original syntax:"))
(send: sbview sb:syntax-browser<%> add-text "\n")
(when stx (send: sbview sb:syntax-browser<%> add-syntax stx)))
(define/private (show-internal-error-details exn events)
(case (message-box/custom "Macro stepper internal error"
@ -91,8 +76,9 @@
((3 #f) (void))))
(define/public (add-error exn)
(send sbview add-error-text (exn-message exn))
(send sbview add-text "\n"))
(send*: sbview sb:syntax-browser<%>
(add-error-text (exn-message exn))
(add-text "\n")))
(define/public (add-step step
#:binders binders
@ -110,21 +96,22 @@
#:binders [binders #f]
#:shift-table [shift-table #f]
#:definites [definites null])
(send sbview add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites definites))
(send: sbview sb:syntax-browser<%> add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites definites))
(define/public (add-final stx error
#:binders binders
#:shift-table [shift-table #f]
#:definites definites)
(when stx
(send sbview add-text "Expansion finished\n")
(send sbview add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites definites))
(send*: sbview sb:syntax-browser<%>
(add-text "Expansion finished\n")
(add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites definites)))
(when error
(add-error error)))
@ -133,17 +120,16 @@
(define state (protostep-s1 step))
(define lctx (state-lctx state))
(when (pair? lctx)
(send sbview add-text "\n")
(for-each (lambda (bf)
(send sbview add-text
"while executing macro transformer in:\n")
(insert-syntax/redex (bigframe-term bf)
(bigframe-foci bf)
binders
shift-table
(state-uses state)
(state-frontier state)))
(reverse lctx))))
(send: sbview sb:syntax-browser<%> add-text "\n")
(for ([bf (reverse lctx)])
(send: sbview sb:syntax-browser<%> add-text
"while executing macro transformer in:\n")
(insert-syntax/redex (bigframe-term bf)
(bigframe-foci bf)
binders
shift-table
(state-uses state)
(state-frontier state)))))
;; separator : Step -> void
(define/private (separator step)
@ -194,15 +180,15 @@
(define state (protostep-s1 step))
(show-state/redex state binders shift-table)
(separator step)
(send sbview add-error-text (exn-message (misstep-exn step)))
(send sbview add-text "\n")
(send*: sbview sb:syntax-browser<%>
(add-error-text (exn-message (misstep-exn step)))
(add-text "\n"))
(when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e)
(send sbview add-syntax e
#:binder-table binders
#:shift-table shift-table
#:definites (or (state-uses state) null)))
(exn:fail:syntax-exprs (misstep-exn step))))
(for ([e (exn:fail:syntax-exprs (misstep-exn step))])
(send: sbview sb:syntax-browser<%> add-syntax e
#:binder-table binders
#:shift-table shift-table
#:definites (or (state-uses state) null))))
(show-lctx step binders shift-table))
;; insert-syntax/color
@ -210,14 +196,14 @@
definites frontier hi-color)
(define highlight-foci? (send config get-highlight-foci?))
(define highlight-frontier? (send config get-highlight-frontier?))
(send sbview add-syntax stx
#:definites (or definites null)
#:binder-table binders
#:shift-table shift-table
#:hi-colors (list hi-color
"WhiteSmoke")
#:hi-stxss (list (if highlight-foci? foci null)
(if highlight-frontier? frontier null))))
(send: sbview sb:syntax-browser<%> add-syntax stx
#:definites (or definites null)
#:binder-table binders
#:shift-table shift-table
#:hi-colors (list hi-color
"WhiteSmoke")
#:hi-stxss (list (if highlight-foci? foci null)
(if highlight-frontier? frontier null))))
;; insert-syntax/redex
(define/private (insert-syntax/redex stx foci binders shift-table
@ -233,29 +219,32 @@
;; insert-step-separator : string -> void
(define/private (insert-step-separator text)
(send sbview add-text "\n ")
(send sbview add-text
(make-object image-snip%
(build-path (collection-path "icons")
"red-arrow.bmp")))
(send sbview add-text " ")
(send sbview add-text text)
(send sbview add-text "\n\n"))
(send*: sbview sb:syntax-browser<%>
(add-text "\n ")
(add-text
(make-object image-snip%
(build-path (collection-path "icons")
"red-arrow.bmp")))
(add-text " ")
(add-text text)
(add-text "\n\n")))
;; insert-as-separator : string -> void
(define/private (insert-as-separator text)
(send sbview add-text "\n ")
(send sbview add-text text)
(send sbview add-text "\n\n"))
(send*: sbview sb:syntax-browser<%>
(add-text "\n ")
(add-text text)
(add-text "\n\n")))
;; insert-step-separator/small : string -> void
(define/private (insert-step-separator/small text)
(send sbview add-text " ")
(send sbview add-text
(make-object image-snip%
(build-path (collection-path "icons")
"red-arrow.bmp")))
(send sbview add-text " ")
(send sbview add-text text)
(send sbview add-text "\n\n"))
(send*: sbview sb:syntax-browser<%>
(add-text " ")
(add-text
(make-object image-snip%
(build-path (collection-path "icons")
"red-arrow.bmp")))
(add-text " ")
(add-text text)
(add-text "\n\n")))
))

130
collects/macro-debugger/view/stepper.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/unit
scheme/list
scheme/match
@ -14,6 +15,7 @@
"hiding-panel.ss"
"term-record.ss"
"step-display.ss"
(prefix-in sb: "../syntax-browser/interfaces.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"
@ -29,10 +31,10 @@
;; macro-stepper-widget%
(define macro-stepper-widget%
(class* object% ()
(class* object% (widget<%>)
(init-field parent)
(init-field config)
(init-field director)
(init-field: (director director<%>))
;; Terms
@ -65,7 +67,7 @@
(define/public (add trec)
(set! all-terms (cons trec all-terms))
(let ([display-new-term? (cursor:at-end? terms)]
[invisible? (send trec get-deriv-hidden?)])
[invisible? (send: trec term-record<%> get-deriv-hidden?)])
(unless invisible?
(cursor:add-to-end! terms (list trec))
(trim-navigator)
@ -83,15 +85,16 @@
(define/public (show-in-new-frame)
(let ([term (focused-term)])
(when term
(let ([new-stepper (send director new-stepper '(no-new-traces))])
(send new-stepper add-deriv (send term get-raw-deriv))
(let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))])
(send: new-stepper widget<%> add-deriv (send term get-raw-deriv))
(void)))))
;; duplicate-stepper : -> void
(define/public (duplicate-stepper)
(let ([new-stepper (send director new-stepper)])
(let ([new-stepper (send: director director<%> new-stepper)])
(for ([term (cursor->list terms)])
(send new-stepper add-deriv (send term get-raw-deriv)))))
(send: new-stepper widget<%> add-deriv
(send: term term-record<%> get-raw-deriv)))))
(define/public (get-config) config)
(define/public (get-controller) sbc)
@ -101,7 +104,7 @@
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
(define/public (reset-primary-partition)
(send sbc reset-primary-partition)
(send: sbc sb:controller<%> reset-primary-partition)
(update/preserve-view))
(define area (new vertical-panel% (parent parent)))
@ -126,16 +129,19 @@
(define warnings-area (new stepper-warnings% (parent area)))
(define sbview (new stepper-syntax-widget%
(parent area)
(macro-stepper this)))
(define step-displayer (new step-display%
(config config)
(syntax-widget sbview)))
(define sbc (send sbview get-controller))
(define: sbview sb:syntax-browser<%>
(new stepper-syntax-widget%
(parent area)
(macro-stepper this)))
(define: step-displayer step-display<%>
(new step-display%
(config config)
(syntax-widget sbview)))
(define: sbc sb:controller<%>
(send sbview get-controller))
(define control-pane
(new vertical-panel% (parent area) (stretchable-height #f)))
(define macro-hiding-prefs
(define: macro-hiding-prefs hiding-prefs<%>
(new macro-hiding-prefs-widget%
(parent control-pane)
(stepper this)
@ -144,7 +150,7 @@
(send config listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-panel show?)))
(send sbc listen-selected-syntax
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
(lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
(send config listen-highlight-foci?
(lambda (_) (update/preserve-view)))
(send config listen-highlight-frontier?
@ -231,36 +237,36 @@
(list navigator)))))
;; Navigation
#|
(define/public-final (at-start?)
(send (focused-term) at-start?))
(send: (focused-term) term-record<%> at-start?))
(define/public-final (at-end?)
(send (focused-term) at-end?))
(send: (focused-term) term-record<%> at-end?))
|#
(define/public-final (navigate-to-start)
(send (focused-term) navigate-to-start)
(send: (focused-term) term-record<%> navigate-to-start)
(update/save-position))
(define/public-final (navigate-to-end)
(send (focused-term) navigate-to-end)
(send: (focused-term) term-record<%> navigate-to-end)
(update/save-position))
(define/public-final (navigate-previous)
(send (focused-term) navigate-previous)
(send: (focused-term) term-record<%> navigate-previous)
(update/save-position))
(define/public-final (navigate-next)
(send (focused-term) navigate-next)
(send: (focused-term) term-record<%> navigate-next)
(update/save-position))
(define/public-final (navigate-to n)
(send (focused-term) navigate-to n)
(send: (focused-term) term-record<%> navigate-to n)
(update/save-position))
(define/public-final (navigate-up)
(when (focused-term)
(send (focused-term) on-lose-focus))
(send: (focused-term) term-record<%> on-lose-focus))
(cursor:move-prev terms)
(refresh/move))
(define/public-final (navigate-down)
(when (focused-term)
(send (focused-term) on-lose-focus))
(send: (focused-term) term-record<%> on-lose-focus))
(cursor:move-next terms)
(refresh/move))
@ -272,7 +278,7 @@
;; update/preserve-lines-view : -> void
(define/public (update/preserve-lines-view)
(define text (send sbview get-text))
(define text (send: sbview sb:syntax-browser<%> get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-line-range start-box end-box)
@ -285,7 +291,7 @@
;; update/preserve-view : -> void
(define/public (update/preserve-view)
(define text (send sbview get-text))
(define text (send: sbview sb:syntax-browser<%> get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-position-range start-box end-box)
@ -295,17 +301,17 @@
;; update : -> void
;; Updates the terms in the syntax browser to the current step
(define/private (update)
(define text (send sbview get-text))
(define text (send: sbview sb:syntax-browser<%> get-text))
(define position-of-interest 0)
(define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence)
(send sbview erase-all)
(send: sbview sb:syntax-browser<%> erase-all)
(update:show-prefix)
(when multiple-terms? (send sbview add-separator))
(when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
(set! position-of-interest (send text last-position))
(update:show-current-step)
(when multiple-terms? (send sbview add-separator))
(when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
(update:show-suffix)
(send text end-edit-sequence)
(send text scroll-to-position
@ -319,35 +325,35 @@
;; update:show-prefix : -> void
(define/private (update:show-prefix)
;; Show the final terms from the cached synth'd derivs
(for-each (lambda (trec) (send trec display-final-term))
(for-each (lambda (trec) (send: trec term-record<%> display-final-term))
(cursor:prefix->list terms)))
;; update:show-current-step : -> void
(define/private (update:show-current-step)
(when (focused-term)
(send (focused-term) display-step)))
(send: (focused-term) term-record<%> display-step)))
;; update:show-suffix : -> void
(define/private (update:show-suffix)
(let ([suffix0 (cursor:suffix->list terms)])
(when (pair? suffix0)
(for-each (lambda (trec)
(send trec display-initial-term))
(send: trec term-record<%> display-initial-term))
(cdr suffix0)))))
;; update-nav-index : -> void
(define/private (update-nav-index)
(define term (focused-term))
(set-current-step-index
(and term (send term get-step-index))))
(and term (send: term term-record<%> get-step-index))))
;; enable/disable-buttons : -> void
(define/private (enable/disable-buttons)
(define term (focused-term))
(send nav:start enable (and term (send term has-prev?)))
(send nav:previous enable (and term (send term has-prev?)))
(send nav:next enable (and term (send term has-next?)))
(send nav:end enable (and term (send term has-next?)))
(send nav:start enable (and term (send: term term-record<%> has-prev?)))
(send nav:previous enable (and term (send: term term-record<%> has-prev?)))
(send nav:next enable (and term (send: term term-record<%> has-next?)))
(send nav:end enable (and term (send: term term-record<%> has-next?)))
(send nav:text enable (and term #t))
(send nav:up enable (cursor:has-prev? terms))
(send nav:down enable (cursor:has-next? terms)))
@ -357,14 +363,14 @@
;; refresh/resynth : -> void
;; Macro hiding policy has changed; invalidate cached parts of trec
(define/public (refresh/resynth)
(for-each (lambda (trec) (send trec invalidate-synth!))
(for-each (lambda (trec) (send: trec term-record<%> invalidate-synth!))
(cursor->list terms))
(refresh))
;; refresh/re-reduce : -> void
;; Reduction config has changed; invalidate cached parts of trec
(define/private (refresh/re-reduce)
(for-each (lambda (trec) (send trec invalidate-steps!))
(for-each (lambda (trec) (send: trec term-record<%> invalidate-steps!))
(cursor->list terms))
(refresh))
@ -377,47 +383,15 @@
(define/public (refresh)
(send warnings-area clear)
(when (focused-term)
(send (focused-term) on-get-focus))
(send: (focused-term) term-record<%> on-get-focus))
(update))
#|
;; delayed-recache-errors : (list-of (cons exn string))
(define delayed-recache-errors null)
;; handle-recache-error : exception string -> void
(define/private (handle-recache-error exn part)
(if (send config get-debug-catch-errors?)
(begin
(set! delayed-recache-errors
(cons (cons exn part) delayed-recache-errors))
(queue-callback
(lambda ()
(when (pair? delayed-recache-errors)
(message-box
"Error"
(string-append
"Internal errors in macro stepper:\n"
(if (memq 'macro-hiding (map cdr delayed-recache-errors))
(string-append
"Macro hiding failed on one or more terms. "
"The macro stepper is showing the terms "
"with macro hiding disabled.\n")
"")
(if (memq 'reductions (map cdr delayed-recache-errors))
(string-append
"The macro stepper failed to compute the reduction sequence "
"for one or more terms.\n")
"")))
(set! delayed-recache-errors null)))))
(raise exn)))
|#
(define/private (foci x) (if (list? x) x (list x)))
;; Hiding policy
(define/public (get-show-macro?)
(send macro-hiding-prefs get-policy))
(send: macro-hiding-prefs hiding-prefs<%> get-policy))
;; Derivation pre-processing

51
collects/macro-debugger/view/term-record.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/unit
scheme/list
scheme/match
@ -30,11 +30,12 @@
;; TermRecords
(define term-record%
(class object%
(init-field stepper)
(class* object% (term-record<%>)
(init-field: (stepper widget<%>))
(define config (send stepper get-config))
(define displayer (send stepper get-step-displayer))
(define: displayer step-display<%>
(send: stepper widget<%> get-step-displayer))
;; Data
@ -128,7 +129,7 @@
(unless (or deriv deriv-hidden?)
(recache-raw-deriv!)
(when raw-deriv
(let ([process (send stepper get-preprocess-deriv)])
(let ([process (send: stepper widget<%> get-preprocess-deriv)])
(let ([d (process raw-deriv)])
(when (not d)
(set! deriv-hidden? #t))
@ -151,7 +152,7 @@
(unless (or raw-steps raw-steps-oops)
(recache-synth!)
(when deriv
(let ([show-macro? (or (send stepper get-show-macro?)
(let ([show-macro? (or (send: stepper widget<%> get-show-macro?)
(lambda (id) #t))])
(with-handlers ([(lambda (e) #t)
(lambda (e)
@ -274,18 +275,18 @@
;; display-initial-term : -> void
(define/public (display-initial-term)
(send displayer add-syntax (wderiv-e1 deriv)))
(send: displayer step-display<%> add-syntax (wderiv-e1 deriv)))
;; display-final-term : -> void
(define/public (display-final-term)
(recache-steps!)
(cond [(syntax? raw-steps-estx)
(send displayer add-syntax raw-steps-estx
#:binders binders
#:shift-table shift-table
#:definites raw-steps-definites)]
(send: displayer step-display<%> add-syntax raw-steps-estx
#:binders binders
#:shift-table shift-table
#:definites raw-steps-definites)]
[(exn? raw-steps-exn)
(send displayer add-error raw-steps-exn)]
(send: displayer step-display<%> add-error raw-steps-exn)]
[else (display-oops #f)]))
;; display-step : -> void
@ -294,25 +295,25 @@
(cond [steps
(let ([step (cursor:next steps)])
(if step
(send displayer add-step step
#:binders binders
#:shift-table shift-table)
(send displayer add-final raw-steps-estx raw-steps-exn
#:binders binders
#:shift-table shift-table
#:definites raw-steps-definites)))]
(send: displayer step-display<%> add-step step
#:binders binders
#:shift-table shift-table)
(send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn
#:binders binders
#:shift-table shift-table
#:definites raw-steps-definites)))]
[else (display-oops #t)]))
;; display-oops : boolean -> void
(define/private (display-oops show-syntax?)
(cond [raw-steps-oops
(send displayer add-internal-error
"steps" raw-steps-oops
(and show-syntax? (wderiv-e1 deriv))
events)]
(send: displayer step-display<%> add-internal-error
"steps" raw-steps-oops
(and show-syntax? (wderiv-e1 deriv))
events)]
[raw-deriv-oops
(send displayer add-internal-error
"derivation" raw-deriv-oops #f events)]
(send: displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)]
[else
(error 'term-record::display-oops "internal error")]))
))

44
collects/macro-debugger/view/view.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/pretty
scheme/gui
framework/framework
@ -13,7 +14,7 @@
go)
(define macro-stepper-director%
(class object%
(class* object% (director<%>)
(define stepper-frames (make-hasheq))
;; Flags is a subset(list) of '(no-obsolete no-new-traces)
@ -27,23 +28,23 @@
(hash-for-each stepper-frames
(lambda (stepper-frame flags)
(unless (memq 'no-obsolete flags)
(send stepper-frame add-obsoleted-warning)))))
(send: stepper-frame stepper-frame<%> add-obsoleted-warning)))))
(define/public (add-trace events)
(hash-for-each stepper-frames
(lambda (stepper-frame flags)
(unless (memq 'no-new-traces flags)
(send (send stepper-frame get-widget)
add-trace events)))))
(send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
add-trace events)))))
(define/public (add-deriv deriv)
(hash-for-each stepper-frames
(lambda (stepper-frame flags)
(unless (memq 'no-new-traces flags)
(send (send stepper-frame get-widget)
add-deriv deriv)))))
(send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
add-deriv deriv)))))
(define/public (new-stepper [flags '()])
(define stepper-frame (new-stepper-frame))
(define stepper (send stepper-frame get-widget))
(define stepper (send: stepper-frame stepper-frame<%> get-widget))
(send stepper-frame show #t)
(add-stepper! stepper-frame flags)
stepper)
@ -64,31 +65,6 @@
(define (go stx)
(define director (new macro-stepper-director%))
(define stepper (send director new-stepper))
(send director add-deriv (trace stx))
(define stepper (send: director director<%> new-stepper))
(send: director director<%> add-deriv (trace stx))
(void))
#|
(define (make-macro-stepper)
(let ([f (new macro-stepper-frame%
(config (new macro-stepper-config/prefs%)))])
(send f show #t)
(send f get-widget)))
(define (go stx)
(let ([stepper (make-macro-stepper)])
(send stepper add-deriv (trace stx))
stepper))
(define (go/deriv deriv)
(let* ([f (new macro-stepper-frame%)]
[w (send f get-widget)])
(send w add-deriv deriv)
(send f show #t)
w))
(define (go/trace events)
(let* ([w (make-macro-stepper)])
(send w add-trace events)
w))
|#

2
collects/mrlib/close-icon.ss
View File

@ -118,4 +118,4 @@
(define f (new frame% [label "test"]))
(define c (new close-icon% [parent f] [callback (λ () (printf "hi\n"))]))
(define gb (new grow-box-spacer-pane% [parent f]))
(send f show #t))
(send f show #t))

2
collects/mzlib/contract.ss
View File

@ -94,4 +94,4 @@
(define (flat-contract/predicate? pred)
(or (flat-contract? pred)
(and (procedure? pred)
(procedure-arity-includes? pred 1))))
(procedure-arity-includes? pred 1))))

2
collects/mzlib/scribblings/trace.scrbl
View File

@ -78,4 +78,4 @@ traced call. It receives the name of the function, the function's
ordinary arguments, its keywords, the values of the keywords, and a
number indicating the depth of the call.
}
}

2
collects/net/scribblings/ssl-tcp-unit.scrbl
View File

@ -53,4 +53,4 @@ connections:
trusted root certificates; @scheme[#f] disables verification of
peer server certificates}
]}
]}

2
collects/plot/plot.scrbl
View File

@ -668,4 +668,4 @@ Returns the altitude (in degrees) from which the 3-D box is viewed.}
Returns the azimuthal angle.}
}
}

2
collects/profj/scribblings/advanced.scrbl
View File

@ -611,4 +611,4 @@ with their values specified by the ArrayInit.
@item{@(scheme false)}
}
}

2
collects/profj/scribblings/beginner.scrbl
View File

@ -252,4 +252,4 @@ The initialization statements pass the value provided to the constructor to the
}
@item{@(scheme true)}
@item{@(scheme false)}
}
}

2
collects/profj/scribblings/intermediate-access.scrbl
View File

@ -421,4 +421,4 @@ us unique. Each constructor may set its own @elemref['(inta "mods")]{access}. A
@item{@(scheme false)}
}
}

2
collects/profj/scribblings/intermediate.scrbl
View File

@ -400,4 +400,4 @@ parameters, then the first statement in the constructor must be a @elemref['(int
@item{@(scheme false)}
}
}

2
collects/redex/examples/beginner.ss
View File

@ -920,4 +920,4 @@ reflects the (broken) spec).
;; timing test
#;
(time (run-tests)
(run-big-test))
(run-big-test))

2
collects/redex/examples/semaphores.ss
View File

@ -163,4 +163,4 @@ semaphores make things much more predictable...
(semaphore-post (semaphore x)))
(begin (semaphore-wait (semaphore x))
(set! y (cons 2 y))
(semaphore-post (semaphore x))))))
(semaphore-post (semaphore x))))))

2
collects/redex/examples/subject-reduction.ss
View File

@ -105,4 +105,4 @@
(define (show term)
(traces reductions term #:pred (pred term)))
(show '((lambda (x (num -> num)) 1) ((lambda (x (num -> num)) x) (lambda (x num) x))))
(show '((lambda (x (num -> num)) 1) ((lambda (x (num -> num)) x) (lambda (x num) x))))

2
collects/redex/examples/subst.ss
View File

@ -68,4 +68,4 @@
(term (λ (z1 x1) (λ (x) z))))
(test-equal (term (subst (x 1 (λ (x x) x))))
(term (λ (x x) x)))
(test-results))
(test-results))

2
collects/redex/gui.ss
View File

@ -85,4 +85,4 @@
[initial-char-width (parameter/c number?)])
(provide reduction-steps-cutoff
default-pretty-printer)
default-pretty-printer)

2
collects/redex/main.ss
View File

@ -5,4 +5,4 @@
(provide (all-from-out "reduction-semantics.ss"
"gui.ss"
"pict.ss"))
(provide render-language)
(provide render-language)

2
collects/redex/pict.ss
View File

@ -102,4 +102,4 @@
[lw->pict
(-> (or/c (listof symbol?) compiled-lang?) lw? pict?)]
[render-lw
(-> (or/c (listof symbol?) compiled-lang?) lw? pict?)])
(-> (or/c (listof symbol?) compiled-lang?) lw? pict?)])

2
collects/redex/private/color-test.ss
View File

@ -66,4 +66,4 @@ In the other window, you expect to see the currently unreducted terms in green a
(,(* (term number_1) 2) word)
dup))
'(1 word)
#:pred last-color-pred))
#:pred last-color-pred))

2
collects/redex/private/core-layout.ss
View File

@ -762,4 +762,4 @@
[else (for-each find/lw e)]))
(find/e in-lws)
lws)
lws)

2
collects/redex/private/lw-test-util.ss
View File

@ -40,4 +40,4 @@
[(string? e) (void)]
[else (for-each find-min/lw e)]))
(find-min/lw lw)
(values min-line min-col)))
(values min-line min-col)))

5
collects/redex/private/matcher-test.ss
View File

@ -442,6 +442,11 @@
'(+ 1 b)
#f)
(test-empty `(side-condition ((any_1 ..._a) (any_2 ..._a))
,(lambda (bindings) (error 'should-not-be-called)))
'((1 2 3) (4 5))
#f)
(test-xab 'exp_1
'(+ 1 2)
(list (make-test-mtch (make-bindings (list (make-bind 'exp_1 '(+ 1 2)))) '(+ 1 2) none)))

3
collects/redex/private/matcher.ss
View File

@ -758,7 +758,8 @@ before the pattern compiler is invoked.
(lambda (exp hole-info)
(let ([matches (match-pat exp hole-info)])
(and matches
(let ([filtered (filter (λ (m) (condition (mtch-bindings m))) matches)])
(let ([filtered (filter (λ (m) (condition (mtch-bindings m)))
(filter-multiples matches))])
(if (null? filtered)
#f
filtered)))))

2
collects/redex/private/pict-test.ss
View File

@ -50,4 +50,4 @@
(render-language x0-10)
(printf "pict-test.ss passed\n"))
(printf "pict-test.ss passed\n"))

2
collects/redex/private/reduction-semantics.ss
View File

@ -1847,4 +1847,4 @@
(provide relation-coverage
covered-cases
(rename-out [fresh-coverage make-coverage])
coverage?)
coverage?)

2
collects/redex/private/rewrite-side-conditions.ss
View File

@ -177,4 +177,4 @@
(current-continuation-marks)
(list (id/depth-id x) (id/depth-id (car dups)))))))
(not same-id?)))
(loop (cdr dups))))]))))
(loop (cdr dups))))]))))

94
collects/redex/private/rg-test.ss
View File

@ -495,11 +495,12 @@
#:var (list (λ _ 'x) (λ _ 'y))))
(term (λ (x) (hole y)))))
;; current-output : (-> (-> any) string)
(define (current-output thunk)
;; output : (-> (-> void) string)
(define (output thunk)
(let ([p (open-output-string)])
(parameterize ([current-output-port p])
(thunk))
(unless (void? (thunk))
(error 'output "expected void result")))
(begin0
(get-output-string p)
(close-output-port p))))
@ -510,28 +511,38 @@
(d 5)
(e e 4)
(n number))
(test (current-output (λ () (redex-check lang d #f)))
(test (output (λ () (redex-check lang d #f)))
"counterexample found after 1 attempts:\n5\n")
(test (redex-check lang d #t) #t)
(test (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t)
(test (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t)
(test (current-output (λ () (redex-check lang (d e) #f)))
(test (output (λ () (redex-check lang d #t))) "")
(test (output (λ () (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2)))
"")
(test (output (λ () (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2)))
"")
(test (output (λ () (redex-check lang (d e) #f)))
"counterexample found after 1 attempts:\n(5 4)\n")
(test (current-output (λ () (redex-check lang d (error 'pred-raised))))
"counterexample found after 1 attempts:\n5\n")
(let* ([p (open-output-string)]
[m (parameterize ([current-error-port p])
(with-handlers ([exn:fail? exn-message])
(redex-check lang d (error 'pred-raised))
'no-exn-raised))])
(test m "error: pred-raised")
(test (get-output-string p) #rx"checking 5 raises.*\n$")
(close-output-port p))
(test (parameterize ([check-randomness (make-random 0 0)])
(redex-check lang n (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 42 x))))
#t)
(test (current-output
(output
(λ ()
(redex-check lang n (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 42 x))))))
"")
(test (output
(λ ()
(parameterize ([check-randomness (make-random 0 0)])
(redex-check lang n (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 0 x z))))))
"counterexample found (z) after 1 attempts:\n0\n")
(test (current-output
(test (output
(λ ()
(parameterize ([check-randomness (make-random 1)])
(redex-check lang d (eq? 42 (term n))
@ -539,19 +550,23 @@
#:source (reduction-relation lang (--> 0 x z))))))
"counterexample found after 1 attempts:\n5\n")
(test (let ([r (reduction-relation lang (--> 0 x z))])
(redex-check lang n (number? (term n))
#:attempts 10
#:source r))
#t)
(output
(λ ()
(redex-check lang n (number? (term n))
#:attempts 10
#:source r))))
"")
(let ()
(define-metafunction lang
[(mf 0) 0]
[(mf 42) 0])
(test (parameterize ([check-randomness (make-random 0 1)])
(redex-check lang (n) (eq? 42 (term n))
#:attempts 1
#:source mf))
#t))
(output
(λ ()
(redex-check lang (n) (eq? 42 (term n))
#:attempts 1
#:source mf))))
""))
(let ()
(define-language L)
(test (with-handlers ([exn:fail? exn-message])
@ -601,21 +616,21 @@
[(i any ...) (any ...)])
;; Dom(f) < Ctc(f)
(test (current-output
(test (output
(λ ()
(parameterize ([generation-decisions
(decisions #:num (list (λ _ 2) (λ _ 5)))])
(check-metafunction-contract f))))
"counterexample found after 1 attempts:\n(5)\n")
;; Rng(f) > Codom(f)
(test (current-output
(test (output
(λ ()
(parameterize ([generation-decisions
(decisions #:num (list (λ _ 3)))])
(check-metafunction-contract f))))
"counterexample found after 1 attempts:\n(3)\n")
;; LHS matches multiple ways
(test (current-output
(test (output
(λ ()
(parameterize ([generation-decisions
(decisions #:num (list (λ _ 1) (λ _ 1))
@ -623,9 +638,9 @@
(check-metafunction-contract g))))
"counterexample found after 1 attempts:\n(1 1)\n")
;; OK -- generated from Dom(h)
(test (check-metafunction-contract h) #t)
(test (output (λ () (check-metafunction-contract h))) "")
;; OK -- generated from pattern (any ...)
(test (check-metafunction-contract i #:attempts 5) #t))
(test (output (λ () (check-metafunction-contract i #:attempts 5))) ""))
;; check-reduction-relation
(let ()
@ -653,11 +668,11 @@
(reverse '((+ (+)) 0))))
(let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))])
(test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t)
(test (current-output
(test (output (λ () (check-reduction-relation S (λ (x) #t) #:attempts 1))) "")
(test (output
(λ () (check-reduction-relation S (λ (x) #f))))
"counterexample found after 1 attempts with name:\n1\n")
(test (current-output
(test (output
(λ () (check-reduction-relation S (curry eq? 1))))
"counterexample found after 1 attempts with unnamed:\n3\n"))
@ -671,11 +686,13 @@
with
[(--> (9 a) b)
(==> a b)])])
(test (check-reduction-relation
T (curry equal? '(9 4))
#:attempts 1
#:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x)))))
#t)))
(test (output
(λ ()
(check-reduction-relation
T (curry equal? '(9 4))
#:attempts 1
#:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x)))))))
"")))
; check-metafunction
(let ()
@ -688,7 +705,8 @@
(check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1)
generated)
(reverse '((1) (2)))))
(test (current-output (λ () (check-metafunction m (curry eq? 1))))
(test (output (λ () (check-metafunction m (λ (_) #t)))) "")
(test (output (λ () (check-metafunction m (curry eq? 1))))
#rx"counterexample found after 1 attempts with clause #1")
(test (with-handlers ([exn:fail:contract? exn-message])
(check-metafunction m #t #:attempts 'NaN))

118
collects/redex/private/rg.ss
View File

@ -680,41 +680,41 @@ To do a better job of not generating programs with free variables,
(quasisyntax/loc stx
(let ([att attempts])
(assert-nat 'redex-check att)
(or (check-property
(cons (list #,(term-generator #'lang #'pat #'random-decisions 'redex-check) #f)
(let ([lang-gen (generate lang (random-decisions lang))])
#,(if (not source-stx)
#'null
#`(let-values
([(pats srcs src-lang)
#,(cond [(and (identifier? source-stx) (metafunc source-stx))
=>
(λ (m) #`(values (metafunc-proc-lhs-pats #,m)
(metafunc-srcs #,m)
(metafunc-proc-lang #,m)))]
[else
#`(let ([r #,source-stx])
(unless (reduction-relation? r)
(raise-type-error 'redex-check "reduction-relation" r))
(values
(map rewrite-proc-lhs (reduction-relation-make-procs r))
(reduction-relation-srcs r)
(reduction-relation-lang r)))])])
(unless (eq? src-lang lang)
(error 'redex-check "language for secondary source must match primary pattern's language"))
(zip (map lang-gen pats) srcs)))))
#,(and source-stx #'(test-match lang pat))
(λ (generated) (error 'redex-check "~s does not match ~s" generated 'pat))
(λ (_ bindings)
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
property))
att
(λ (term attempt source port)
(fprintf port "counterexample found~aafter ~a attempts:\n"
(if source (format " (~a) " source) " ") attempt)
(pretty-print term port))
(check-randomness))
(void))))))]))
(check-property
(cons (list #,(term-generator #'lang #'pat #'random-decisions 'redex-check) #f)
(let ([lang-gen (generate lang (random-decisions lang))])
#,(if (not source-stx)
#'null
#`(let-values
([(pats srcs src-lang)
#,(cond [(and (identifier? source-stx) (metafunc source-stx))
=>
(λ (m) #`(values (metafunc-proc-lhs-pats #,m)
(metafunc-srcs #,m)
(metafunc-proc-lang #,m)))]
[else
#`(let ([r #,source-stx])
(unless (reduction-relation? r)
(raise-type-error 'redex-check "reduction-relation" r))
(values
(map rewrite-proc-lhs (reduction-relation-make-procs r))
(reduction-relation-srcs r)
(reduction-relation-lang r)))])])
(unless (eq? src-lang lang)
(error 'redex-check "language for secondary source must match primary pattern's language"))
(zip (map lang-gen pats) srcs)))))
#,(and source-stx #'(test-match lang pat))
(λ (generated) (error 'redex-check "~s does not match ~s" generated 'pat))
(λ (_ bindings)
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
property))
att
(λ (term attempt source port)
(fprintf port "counterexample found~aafter ~a attempts:\n"
(if source (format " (~a) " source) " ") attempt)
(pretty-print term port))
(check-randomness))
(void)))))]))
(define (check-property gens-srcs match match-fail property attempts display [random random])
(let loop ([remaining attempts])
@ -729,7 +729,11 @@ To do a better job of not generating programs with free variables,
[(term bindings)
(generator (attempt->size attempt) attempt)])
(if (andmap (λ (bindings)
(with-handlers ([exn:fail? (λ (_) #f)])
(with-handlers ([exn:fail? (λ (exn)
(fprintf (current-error-port)
"checking ~s raises ~s\n"
term exn)
(raise exn))])
(property term bindings)))
(cond [(and match (match term))
=> (curry map (compose make-bindings match-bindings))]
@ -758,11 +762,14 @@ To do a better job of not generating programs with free variables,
(list (list ((generate lang (decisions lang)) (if dom dom '(any (... ...)))) #f))
#f
#f
(λ (t _) (begin (term (name ,@t)) #t))
(λ (t _)
(with-handlers ([exn:fail:redex? (λ (_) #f)])
(begin (term (name ,@t)) #t)))
att
(λ (term attempt _ port)
(fprintf port "counterexample found after ~a attempts:\n" attempt)
(pretty-print term port))))))]))
(pretty-print term port)))
(void))))]))
(define (check-property-many lang pats srcs prop decisions attempts)
(let ([lang-gen (generate lang (decisions lang))])
@ -777,7 +784,8 @@ To do a better job of not generating programs with free variables,
(λ (term attempt source port)
(fprintf port "counterexample found after ~a attempts with ~a:\n"
attempt source)
(pretty-print term port))))))
(pretty-print term port))))
(void)))
(define (metafunc-srcs m)
(build-list (length (metafunc-proc-lhs-pats m))
@ -792,14 +800,13 @@ To do a better job of not generating programs with free variables,
(syntax/loc stx
(let ([att attempts])
(assert-nat 'check-metafunction att)
(or (check-property-many
(metafunc-proc-lang m)
(metafunc-proc-lhs-pats m)
(metafunc-srcs m)
property
(generation-decisions)
att)
(void)))))]))
(check-property-many
(metafunc-proc-lang m)
(metafunc-proc-lhs-pats m)
(metafunc-srcs m)
property
(generation-decisions)
att))))]))
(define (reduction-relation-srcs r)
(map (λ (proc) (or (rewrite-proc-name proc) 'unnamed))
@ -809,14 +816,13 @@ To do a better job of not generating programs with free variables,
relation property
#:decisions [decisions random-decisions]
#:attempts [attempts default-check-attempts])
(or (check-property-many
(reduction-relation-lang relation)
(map rewrite-proc-lhs (reduction-relation-make-procs relation))
(reduction-relation-srcs relation)
property
decisions
attempts)
(void)))
(check-property-many
(reduction-relation-lang relation)
(map rewrite-proc-lhs (reduction-relation-make-procs relation))
(reduction-relation-srcs relation)
property
decisions
attempts))
(define-signature decisions^
(next-variable-decision
@ -853,4 +859,4 @@ To do a better job of not generating programs with free variables,
generation-decisions)
(provide/contract
[find-base-cases (-> compiled-lang? hash?)])
[find-base-cases (-> compiled-lang? hash?)])

363
collects/redex/private/size-snip.ss
View File

@ -1,196 +1,171 @@
(module size-snip mzscheme
(require (lib "mred.ss" "mred")
(lib "class.ss")
(lib "pretty.ss")
(lib "framework.ss" "framework")
"matcher.ss")
(provide reflowing-snip<%>
size-editor-snip%
default-pretty-printer
initial-char-width
resizing-pasteboard-mixin)
(define initial-char-width (make-parameter 30))
(define (default-pretty-printer v port w spec)
(parameterize ([pretty-print-columns w]
[pretty-print-size-hook
(λ (val display? op)
(cond
[(hole? val) 4]
[(eq? val 'hole) 6]
[else #f]))]
[pretty-print-print-hook
(λ (val display? op)
(cond
[(hole? val)
(display "hole" op)]
[(eq? val 'hole)
(display ",'hole" op)]))])
(pretty-print v port)))
(define reflowing-snip<%>
(interface ()
reflow-program))
(define (resizing-pasteboard-mixin pb%)
(class pb%
(init-field shrink-down?)
(define/augment (on-interactive-resize snip)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program))
(inner (void) on-interactive-resize snip))
(define/augment (after-interactive-resize snip)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program))
(inner (void) after-interactive-resize snip))
(define/override (interactive-adjust-resize snip w h)
(super interactive-adjust-resize snip w h)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program)))
(inherit get-snip-location
begin-edit-sequence
end-edit-sequence)
(define/augment (on-insert snip before x y)
(begin-edit-sequence)
(inner (void) on-insert snip before x y))
(define/augment (after-insert snip before x y)
(inner (void) after-insert snip before x y)
(when (is-a? snip size-editor-snip%)
(let ([cw (send snip get-char-width)]
[woc (send snip get-width-of-char)]
[bt (box 0)]
[bb (box 0)])
(get-snip-location snip #f bt #f)
(get-snip-location snip #f bb #t)
(send snip resize
(* cw woc)
(- (unbox bb) (unbox bt)))
(when shrink-down?
(send snip shrink-down))))
(end-edit-sequence))
(super-new)))
(define size-editor-snip%
(class* editor-snip% (reflowing-snip<%>)
(init-field expr)
(init pp)
(init-field char-width)
(define real-pp
(if (procedure-arity-includes? pp 4)
pp
(lambda (v port w spec) (display (pp v) port))))
(inherit get-admin)
(define/public (get-expr) expr)
(define/public (get-char-width) char-width)
(define/override (resize w h)
(super resize w h)
(reflow-program))
(inherit get-editor)
;; final
(define/pubment (reflow-program)
(let* ([tw (get-width-of-char)]
[sw (get-snip-width)])
(when (and tw sw)
(let ([new-width (max 1 (inexact->exact (floor (/ sw tw))))])
(unless (equal? new-width char-width)
(set! char-width new-width)
(format-expr)
(on-width-changed char-width))))))
;; final
(define/pubment (shrink-down)
(let ([ed (get-editor)]
[bx (box 0)]
[by (box 0)])
(let ([max-line-width
(let loop ([p 0]
[max-w 0])
(cond
[(<= p (send ed last-paragraph))
(send ed position-location
(send ed paragraph-end-position p)
bx by #t)
(let ([this-w (unbox bx)])
(loop (+ p 1)
(max this-w max-w)))]
[else max-w]))])
(send ed position-location (send ed last-position) bx by #f)
(let-values ([(hms vms) (get-margin-space)])
(super resize
(+ max-line-width hms)
(+ (unbox by) vms))))))
(inherit get-margin)
(define/public (get-snip-width)
(let ([admin (get-admin)])
(and admin
(let ([containing-editor (send admin get-editor)]
[bl (box 0)]
[br (box 0)])
(send containing-editor get-snip-location this bl #f #f)
(send containing-editor get-snip-location this br #f #t)
(let ([outer-w (- (unbox br) (unbox bl))])
(let-values ([(hms vms) (get-margin-space)])
(- outer-w hms)))))))
(define/private (get-margin-space)
(let ([bl (box 0)]
[br (box 0)]
[bt (box 0)]
[bb (box 0)])
(get-margin bl bt br bb)
(values (+ (unbox bl) (unbox br) 2) ;; not sure what the 2 is for. Maybe caret space?
(+ (unbox bt) (unbox bb)))))
(define/public (get-width-of-char)
(let ([ed (get-editor)])
(and ed
(let ([dc (send ed get-dc)]
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
(and dc
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
(and std-style
(send std-style get-font)))])
tw))))))
(define/public (get-height-of-char)
(let ([ed (get-editor)])
(and ed
(let ([dc (send ed get-dc)]
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
(and dc
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
(and std-style
(send std-style get-font)))])
th))))))
#lang scheme/base
(require scheme/gui/base
scheme/class
framework
scheme/pretty
"matcher.ss")
(define/pubment (on-width-changed w) (inner (void) on-width-changed w))
(define/public (format-expr)
(let* ([text (get-editor)]
[port (open-output-text-editor text)])
(send text begin-edit-sequence)
(when (is-a? text color:text<%>)
(send text thaw-colorer))
(send text set-styles-sticky #f)
(send text erase)
(real-pp expr port char-width text)
(unless (zero? (send text last-position))
(when (char=? #\newline (send text get-character (- (send text last-position) 1)))
(send text delete (- (send text last-position) 1) (send text last-position))))
(when (is-a? text color:text<%>)
(send text freeze-colorer))
(send text end-edit-sequence)))
(provide reflowing-snip<%>
size-editor-snip%
size-text%
default-pretty-printer
initial-char-width
resizing-pasteboard-mixin)
(define initial-char-width (make-parameter 30))
(define (default-pretty-printer v port w spec)
(parameterize ([pretty-print-columns w]
[pretty-print-size-hook
(λ (val display? op)
(cond
[(hole? val) 4]
[(eq? val 'hole) 6]
[else #f]))]
[pretty-print-print-hook
(λ (val display? op)
(cond
[(hole? val)
(display "hole" op)]
[(eq? val 'hole)
(display ",'hole" op)]))])
(pretty-print v port)))
(define reflowing-snip<%>
(interface ()
reflow-program))
(define (resizing-pasteboard-mixin pb%)
(class pb%
(define/augment (on-interactive-resize snip)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program))
(inner (void) on-interactive-resize snip))
(define/augment (after-interactive-resize snip)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program))
(inner (void) after-interactive-resize snip))
(define/override (interactive-adjust-resize snip w h)
(super interactive-adjust-resize snip w h)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program)))
(inherit get-snip-location
begin-edit-sequence
end-edit-sequence
find-first-snip
get-dc)
(super-new)))
(define size-editor-snip%
(class* editor-snip% (reflowing-snip<%>)
(init-field expr)
(init pp)
(init-field char-width)
(define real-pp
(if (procedure-arity-includes? pp 4)
pp
(lambda (v port w spec) (display (pp v) port))))
(inherit get-admin)
(define/public (get-expr) expr)
(define/public (get-char-width) char-width)
(define/override (resize w h)
(super resize w h)
(reflow-program))
(inherit get-editor)
;; final
(define/pubment (reflow-program)
(let* ([tw (get-width-of-char)]
[sw (get-snip-width)])
(when (and tw sw)
(let ([new-width (max 1 (inexact->exact (floor (/ sw tw))))])
(unless (equal? new-width char-width)
(set! char-width new-width)
(format-expr)
(on-width-changed char-width))))))
(inherit get-margin)
(define/public (get-snip-width)
(let ([admin (get-admin)])
(and admin
(let ([containing-editor (send admin get-editor)]
[bl (box 0)]
[br (box 0)])
(send containing-editor get-snip-location this bl #f #f)
(send containing-editor get-snip-location this br #f #t)
(let ([outer-w (- (unbox br) (unbox bl))])
(let-values ([(hms vms) (get-margin-space)])
(- outer-w hms)))))))
(define/private (get-margin-space)
(let ([bl (box 0)]
[br (box 0)]
[bt (box 0)]
[bb (box 0)])
(get-margin bl bt br bb)
(values (+ (unbox bl) (unbox br) 6) ;; not sure what the 2 is for. Maybe caret space?
(+ (unbox bt) (unbox bb)))))
;; get-width-of-char : -> number or false
;; depends on `dc' field
(define/public (get-width-of-char)
(let ([ed (get-editor)])
(and ed
(let ([std-style (send (editor:get-standard-style-list) find-named-style "Standard")]
[dc (send ed get-dc)])
(and dc
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
(and std-style
(send std-style get-font)))])
tw))))))
;; depends on `dc' field
(define/public (get-height-of-char)
(let ([ed (get-editor)])
(and ed
(let ([dc (send ed get-dc)]
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
(and dc
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
(and std-style
(send std-style get-font)))])
th))))))
(define/pubment (on-width-changed w) (inner (void) on-width-changed w))
(define/public (format-expr)
(let* ([text (get-editor)]
[port (open-output-text-editor text)])
(send text begin-edit-sequence)
(when (is-a? text color:text<%>)
(send text thaw-colorer))
(send text set-styles-sticky #f)
(send text erase)
(real-pp expr port char-width text)
(unless (zero? (send text last-position))
(when (char=? #\newline (send text get-character (- (send text last-position) 1)))
(send text delete (- (send text last-position) 1) (send text last-position))))
(when (is-a? text color:text<%>)
(send text freeze-colorer))
(send text end-edit-sequence)))
(super-new)
(inherit use-style-background)
(use-style-background #t)))
(define size-text%
(scheme:set-mode-mixin
(scheme:text-mixin
(color:text-mixin
(text:autocomplete-mixin
(mode:host-text-mixin
(editor:standard-style-list-mixin
text:basic%)))))))
(super-new)
(inherit use-style-background)
(use-style-background #t))))

34
collects/redex/private/stepper.ss
View File

@ -77,7 +77,6 @@ todo:
(define upper-hp (new horizontal-panel% [parent dp]))
(define lower-hp (new horizontal-panel% [alignment '(center center)] [parent f] [stretchable-height #f]))
(define pb (new columnar-pasteboard%
[shrink-down? #f]
[moved (λ (a b c d)
(when (procedure? moved)
(moved a b c d)))]))
@ -801,7 +800,7 @@ todo:
flat-to-remove)
(for-each (λ (x) (insert x)) flat-to-insert)))
(inherit get-admin move-to resize)
(inherit get-admin move-to)
(define/public (update-heights)
(let ([admin (get-admin)])
(let-values ([(w h) (get-view-size)])
@ -816,9 +815,11 @@ todo:
;; if there is only a single snip in the column, we let it be as long as it wants to be.
(let* ([snip (car column)]
[sw (get-snip-width snip)]
[sh (get-snip-max-height snip)])
[sh (get-snip-max-height snip)]
[new-height (- (max h sh) (get-border-height snip))])
(move-to snip x 0)
(resize snip sw (max h sh))
(send snip set-min-height new-height)
(send snip set-max-height new-height)
(loop (cdr columns) (+ x sw)))]
[else
;; otherwise, we make all of the snips fit into the visible area
@ -838,16 +839,39 @@ todo:
0
1))])
(move-to snip x y)
(resize snip sw h)
(let ([border-height (get-border-height snip)])
(send snip set-min-height (- h border-height))
(send snip set-max-height (- h border-height)))
(loop (cdr snips)
(if (zero? extra-space)
0
(- extra-space 1))
(+ y h)
(max widest sw)))]))])
(for-each (λ (snip)
(let ([border-width (get-border-width snip)])
(send snip set-min-width (- widest border-width))
(send snip set-max-width (- widest border-width))))
column)
(loop (cdr columns)
(+ x widest)))]))])))))
(define/private (get-border-height snip)
(let ([lb (box 0)]
[tb (box 0)]
[rb (box 0)]
[bb (box 0)])
(send snip get-margin lb tb bb rb)
(+ (unbox bb) (unbox tb))))
(define/private (get-border-width snip)
(let ([lb (box 0)]
[tb (box 0)]
[rb (box 0)]
[bb (box 0)])
(send snip get-margin lb tb bb rb)
(+ (unbox lb) (unbox rb))))
(inherit get-snip-location)
(define/public (get-snip-width snip)
(let ([lb (box 0)]

2
collects/redex/private/term-test.ss
View File

@ -76,4 +76,4 @@
(term (((metafun x) y) ...))))
'((whatever 4) (whatever 5) (whatever 6)))
(print-tests-passed 'term-test.ss))
(print-tests-passed 'term-test.ss))

2
collects/redex/private/term.ss
View File

@ -127,4 +127,4 @@
(with-syntax ([x rhs] ...)
(begin body1 body2 ...)))]
[(_ x)
(raise-syntax-error 'term-let "expected at least one body" stx)])))
(raise-syntax-error 'term-let "expected at least one body" stx)])))

115
collects/redex/private/traces.ss
View File

@ -1,15 +1,17 @@
#lang scheme/base
;; should cache the count of new snips -- dont
;; use `count-snips'; use something associated with the
;; equal hash-table
#lang scheme
(require mrlib/graph
"reduction-semantics.ss"
"matcher.ss"
"size-snip.ss"
"dot.ss"
scheme/gui/base
scheme/class
scheme/file
framework)
(preferences:set-default 'plt-reducer:show-bottom #t boolean?)
@ -139,12 +141,83 @@
#:scheme-colors? scheme-colors?
#:colors colors
#:layout layout)])
(let ([ps-setup (make-object ps-setup%)])
(send ps-setup copy-from (current-ps-setup))
(send ps-setup set-file filename)
(send ps-setup set-mode 'file)
(parameterize ([current-ps-setup ps-setup])
(send graph-pb print #f #f 'postscript #f #f #t)))))
(print-to-ps graph-pb filename)))
(define (print-to-ps graph-pb filename)
(let ([admin (send graph-pb get-admin)]
[printing-admin (new printing-editor-admin%)])
(send graph-pb set-admin printing-admin)
(dynamic-wind
void
(λ ()
(let loop ([snip (send graph-pb find-first-snip)])
(when snip
(send snip size-cache-invalid)
(loop (send snip next))))
(send graph-pb invalidate-bitmap-cache)
(send graph-pb re-run-layout)
(let ([ps-setup (make-object ps-setup%)])
(send ps-setup copy-from (current-ps-setup))
(send ps-setup set-file filename)
(send ps-setup set-mode 'file)
(parameterize ([current-ps-setup ps-setup])
(send graph-pb print #f #f 'postscript #f #f #t))))
(λ ()
(send graph-pb set-admin admin)
(send printing-admin shutdown) ;; do this early
(let loop ([snip (send graph-pb find-first-snip)])
(when snip
(send snip size-cache-invalid)
(loop (send snip next))))
(send graph-pb invalidate-bitmap-cache)
(send graph-pb re-run-layout)))))
(define printing-editor-admin%
(class editor-admin%
(define temp-file (make-temporary-file "redex-size-snip-~a"))
(define ps-dc
(let ([ps-setup (make-object ps-setup%)])
(send ps-setup copy-from (current-ps-setup))
(send ps-setup set-file temp-file)
(parameterize ([current-ps-setup ps-setup])
(make-object post-script-dc% #f #f #f #t))))
(send ps-dc start-doc "fake dc")
(send ps-dc start-page)
(super-new)
(define/public (shutdown)
(send ps-dc end-page)
(send ps-dc end-doc)
(delete-file temp-file))
(define/override (get-dc [x #f] [y #f])
(super get-dc x y)
ps-dc)
(define/override (get-max-view x y w h [full? #f])
(get-view x y w h full?))
(define/override (get-view x y w h [full? #f])
(super get-view x y w h full?)
(when (box? w) (set-box! w 500))
(when (box? h) (set-box! h 500)))
;; the following methods are not overridden; they all default to doing nothing.
;; grab-caret
;; modified
;; needs-update
;; popup-menu
;; refresh-delayed?
;; resized
;; scroll-to
;; update-cursor
))
(define (traces reductions pre-exprs
#:multiple? [multiple? #f]
@ -157,7 +230,7 @@
(define exprs (if multiple? pre-exprs (list pre-exprs)))
(define main-eventspace (current-eventspace))
(define saved-parameterization (current-parameterization))
(define graph-pb (new graph-pasteboard% [shrink-down? #t]))
(define graph-pb (new graph-pasteboard% [layout layout]))
(define f (instantiate red-sem-frame% ()
(label "PLT Redex Reduction Graph")
(style '(toolbar-button))
@ -275,7 +348,7 @@
(let loop ([snip (send graph-pb find-first-snip)])
(when snip
(when (is-a? snip reflowing-snip<%>)
(send snip shrink-down))
(send snip reflow-program))
(loop (send snip next))))))
;; fill-out : (listof X) (listof X) -> (listof X)
@ -338,7 +411,7 @@
(set! col (+ x-spacing (find-rightmost-x graph-pb))))
(begin0
(insert-into col y graph-pb new-snips)
(layout (hash-map snip-cache (lambda (x y) (send y get-term-node))))
(send graph-pb re-run-layout)
(send graph-pb end-edit-sequence)
(send status-message set-label
(string-append (term-count (count-snips)) "...")))))])
@ -469,7 +542,7 @@
null)))
(out-of-dot-state) ;; make sure the state is initialized right
(insert-into init-rightmost-x 0 graph-pb frontier)
(layout (map (lambda (y) (send y get-term-node)) frontier))
(send graph-pb re-run-layout)
(set-font-size (initial-font-size))
(cond
[no-show-frame?
@ -507,6 +580,10 @@
(define graph-pasteboard%
(class (resizing-pasteboard-mixin
(graph-pasteboard-mixin pasteboard%))
(init-field layout) ;; (-> (listof term-node) void)
;; this is the function supplied by the :#layout argument to traces or traces/ps
(define dot-callback #f)
(define/public (set-dot-callback cb) (set! dot-callback cb))
(define/override (draw-edges dc left top right bottom dx dy)
@ -521,6 +598,17 @@
(define/augment (can-interactive-move? evt) mobile?)
(define/augment (can-interactive-resize? evt) mobile?)
(inherit find-first-snip)
(define/public (re-run-layout)
(layout
(let loop ([snip (find-first-snip)])
(cond
[(not snip) '()]
[(is-a? snip reflowing-snip<%>)
(cons (send snip get-term-node)
(loop (send snip next)))]
[else (loop (send snip next))]))))
(super-new)))
(define graph-editor-snip%
@ -578,7 +666,7 @@
(super-new)))
(define program-text%
(class scheme:text%
(class size-text%
(define bad-color #f)
(define/public (set-bad color) (set! bad-color color))
@ -688,6 +776,7 @@
(pp pp)
(expr expr))])
(send text set-autowrap-bitmap #f)
(send text set-max-width 'none)
(send text freeze-colorer)
(send text stop-colorer (not scheme-colors?))
(send es format-expr)

2
collects/redex/private/underscore-allowed.ss
View File

@ -1,3 +1,3 @@
(module underscore-allowed mzscheme
(provide underscore-allowed)
(define underscore-allowed '(any number string variable)))
(define underscore-allowed '(any number string variable)))

28
collects/redex/redex.scrbl
View File

@ -213,12 +213,13 @@ looking for a decomposition, it ignores any holes found in
that @|pattern|.
}
@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern matches
what the embedded @pattern matches, and then the guard expression is
evaluated. If it returns @scheme[#f], the @pattern fails to match, and if it
returns anything else, the @pattern matches. In addition, any
occurrences of `name' in the @pattern are bound using @scheme[term-let]
in the guard.
@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern
matches what the embedded @pattern matches, and then the guard
expression is evaluated. If it returns @scheme[#f], the @pattern fails
to match, and if it returns anything else, the @pattern matches. Any
occurrences of `name' in the @pattern (including those implicitly
there via @tt{_} pattersn) are bound using @scheme[term-let] in the
guard.
}
@item{The @tt{(@defpattech[cross] symbol)} @pattern is used for the compatible
@ -1095,7 +1096,7 @@ pattern does not match the @scheme[pattern].}
[relation reduction-relation?]
[property (-> any/c any/c)]
[#:attempts attempts natural-number/c 100])
(or/c true/c void?)]{
void?]{
Tests a @scheme[relation] as follows: for each case of @scheme[relation],
@scheme[check-reduction-relation] generates @scheme[attempts] random
terms that match that case's left-hand side and applies @scheme[property]
@ -1367,9 +1368,18 @@ the stepper and traces.
@defparam[dark-pen-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[dark-brush-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[light-pen-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[light-brush-color color (or/c string? (is-a?/c color<%>))]{}]]{
@defparam[light-brush-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[dark-text-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[light-text-color color (or/c string? (is-a?/c color<%>))]{}]]{
These four parameters control the color of the edges in the graph.
These six parameters control the color of the edges in the graph.
The dark colors are used when the mouse is over one of the nodes that
is connected to this edge. The light colors are used when it isn't.
The pen colors control the color of the line. The brush colors control
the color used to fill the arrowhead and the text colors control the
color used to draw the label on the edge.
}
@defproc[(default-pretty-printer [v any] [port output-port] [width number] [text (is-a?/c text%)]) void?]{

2
collects/redex/reduction-semantics.ss
View File

@ -70,4 +70,4 @@
(one-of/c #t (void)))]
[relation-coverage (parameter/c (or/c false/c coverage?))]
[make-coverage (-> reduction-relation? coverage?)]
[covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))])
[covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))])

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "12jan2009")
#lang scheme/base (provide stamp) (define stamp "14jan2009")

1
collects/scheme/private/map.ss
View File

@ -127,4 +127,3 @@
(ormap f l1 l2))]
[(f . args) (apply ormap f args)])])
ormap)))

2
collects/scribble/private/manual-style.ss
View File

@ -240,4 +240,4 @@
(list (make-element 'italic (list i)))])]
[(eq? i 'rsquo) (list 'prime)]
[else (list i)])))
c))))
c))))

2
collects/scribblings/framework/standard-menus.scrbl
View File

@ -349,4 +349,4 @@
@(defmethod (help-menu:after-about (menu (is-a?/c menu-item%))) void? "This method is called " "after" " the addition of the" "\n" (tt "about") " menu-item. Override it to add additional" "\n" "menu items at that point. ")
}
}

4
collects/scribblings/gui/blurbs.ss
View File

@ -267,8 +267,8 @@ information@|details|, even if the editor currently has delayed refreshing (see
(define (edsnipsize a b c)
@elem{An @scheme[editor-snip%] normally stretches to wrap around the size
of the editor it contains. This method #1 of the snip
(and if the editor is #2, #3).})
of the editor it contains. This method @|a| of the snip
(and if the editor is @|b|, @|c|).})
(define (edsnipmax n)
(edsnipsize @elem{limits the @|n|}
@elem{larger}

2
collects/scribblings/tools/tool-lib-extracts.ss
View File

@ -2,4 +2,4 @@
(require scribble/extract)
(provide-extracted (lib "tool-lib.ss" "drscheme"))
(provide-extracted (lib "tool-lib.ss" "drscheme"))

2
collects/srfi/42/comprehensions.scm
View File

@ -401,4 +401,4 @@
(qualifier)
(first-ec #t qualifier (if (not expression)) #f) ))
)
)

2
collects/srfi/42/generator-definitions.scm
View File

@ -35,4 +35,4 @@
(raise-syntax-error
'define-generator
"expected either (define-generator <id> <proc>) or (define-generator (<id1> <id2>) <body> ... , got: "
stx)])))
stx)])))

2
collects/srfi/42/generator-struct.scm
View File

@ -14,4 +14,4 @@
; of a generator clause as input. For example
; #'(:list x (list 1 2 3)). The function form->loop
; returns a loop structure.
(define-struct generator (name clause->loop)))
(define-struct generator (name clause->loop)))

2
collects/srfi/42/generators.scm
View File

@ -455,4 +455,4 @@
"expected (:while <generator> <expr>) got: "
form-stx)]))
)
)

2
collects/srfi/42/loops.scm
View File

@ -107,4 +107,4 @@
(if ne2
(loop ls ...))))))))))]))
)
)

2
collects/srfi/42/simplifier.scm
View File

@ -90,4 +90,4 @@
; anything else
((ec-simplify expression)
#'expression ))))
#'expression ))))

2
collects/stepper/private/debugger-summary.txt
View File

@ -13,4 +13,4 @@
by the chosen frame
(bound) : all bound vars
(v <x>) : value of a named variable
(src) : the source code
(src) : the source code

2
collects/syntax/modcollapse.ss
View File

@ -23,4 +23,4 @@
. -> . simple-rel-to-module-path-v/c)]
[collapse-module-path-index ((or/c symbol? module-path-index?)
rel-to-module-path-v/c
. -> . simple-rel-to-module-path-v/c)])
. -> . simple-rel-to-module-path-v/c)])

2
collects/syntax/private/modhelp.ss
View File

@ -17,4 +17,4 @@
(define (module-path-v? v)
(or (path? v)
(module-path? v)))
(module-path? v)))

2
collects/teachpack/door.ss
View File

@ -56,4 +56,4 @@
l4)
(fsa "locked" "closed" "open" "unlock" "lock" "push" "time")
(fsa "'locked" "'closed" "'open" "#\\u" "#\\l" "#\\space" "tick")
(fsa "'locked" "'closed" "'open" "#\\u" "#\\l" "#\\space" "tick")

2
collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss
View File

@ -76,4 +76,4 @@
;; -------------------------------
(command-line #:args (n)
(main (string->number n)))
(main (string->number n)))

2
collects/tests/typed-scheme/660-examples/hw02.scm
View File

@ -235,4 +235,4 @@
|#|#
)
)

2
collects/tests/typed-scheme/660-examples/hw04.scm
View File

@ -346,4 +346,4 @@
{fun main {foo} {call foo foo}}}"
1))
)
)

2
collects/tests/typed-scheme/660-examples/hw05.scm
View File

@ -219,4 +219,4 @@ Evaluation rules:
{fun {x} {fun {y} {+ x y}}}}
123}")
=> 124)
|#)
|#)

2
collects/tests/typed-scheme/fail/apply-dots.ss
View File

@ -10,4 +10,4 @@
(apply (case-lambda: (([x : Number] . [y : Number ... a]) x)
(([x : String] [y : String] . [z : String *]) 0)
([y : String *] 0))
w))
w))

2
collects/tests/typed-scheme/fail/cl-bug.ss
View File

@ -4,4 +4,4 @@
(define (f3 x y) (+ x y))
(: f2 (case-lambda (Number * -> Number)))
(define (f2 x y) (+ x y))
(define (f2 x y) (+ x y))

2
collects/tests/typed-scheme/fail/dotted-identity.ss
View File

@ -8,4 +8,4 @@
(: g (All (b ...) ( -> (b ... b -> Integer))))
(define (g) (lambda xs 0))
(f (g))
(f (g))

2
collects/tests/typed-scheme/fail/formal-len-mismatches.ss
View File

@ -14,4 +14,4 @@
(: f3 (Integer Integer -> Integer))
(define (f3 x . z)
(apply + #\c x z))
(apply + #\c x z))

2
collects/tests/typed-scheme/fail/nested-tvars.ss
View File

@ -6,4 +6,4 @@
(define (g x y) y)
(g "foo" (list "foo")))
(f 3)
(f 3)

2
collects/tests/typed-scheme/fail/unbound-type.ss
View File

@ -6,4 +6,4 @@
(: f (Foo -> String))
(define (f x) (string-append x))
(f 1)
(f 1)

2
collects/tests/typed-scheme/succeed/cl-bug.ss
View File

@ -4,4 +4,4 @@
(define (f . x) (+ 1 2))
(: f4 (case-lambda (Integer * -> Integer) (Number * -> Number)))
(define (f4 . x) (apply + x))
(define (f4 . x) (apply + x))

2
collects/tests/typed-scheme/succeed/dot-intro.ss
View File

@ -13,4 +13,4 @@
y)
(plambda: (a ...) ([x : Number] . [y : Number ... a])
(map add1 y))
(map add1 y))

2
collects/tests/typed-scheme/succeed/fold-left-inst.ss
View File

@ -16,4 +16,4 @@
c
(apply f
(apply (inst fold-left c a b ... b) f c (cdr as) (map cdr bss))
(car as) (map car bss))))
(car as) (map car bss))))

2
collects/tests/typed-scheme/succeed/fold-left.ss
View File

@ -38,4 +38,4 @@
3 4 5)
(fold-left (lambda: ([a : (Listof Integer)] [c : Integer]) (cons c a)) null (list 3 4 5 6))
(fold-right (lambda: ([a : (Listof Integer)] [c : Integer]) (cons c a)) null (list 3 4 5 6))
(fold-right (lambda: ([a : (Listof Integer)] [c : Integer]) (cons c a)) null (list 3 4 5 6))

2
collects/tests/typed-scheme/succeed/foldo.scm
View File

@ -55,4 +55,4 @@
'()
root
))
)
)

1
collects/tests/typed-scheme/succeed/hw01.scm
View File

@ -108,4 +108,3 @@
(= 0 (list-length '()))
(= 2 (list-length '(1 2)))
(= 3 (list-length '(1 2 (1 2 3 4))))

2
collects/tests/typed-scheme/succeed/lots-o-bugs.ss
View File

@ -18,4 +18,4 @@
#;((plambda: (a ...) () (lambda: [ys : a ... a] 3)))
#;((plambda: (a ...) [xs : a ... a] (lambda: [ys : a ... a] 3))
1 2 3 "foo")
1 2 3 "foo")

2
collects/tests/typed-scheme/succeed/nested-poly.ss
View File

@ -17,4 +17,4 @@
(apply f as))
fs))))
(inst map-with-funcs Integer Integer Integer Integer)
(inst map-with-funcs Integer Integer Integer Integer)

Some files were not shown because too many files have changed in this diff Show More