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

Syncing up to trunk.

Browse Source 
svn: r13115
This commit is contained in:
Stevie Strickland 2009-01-14 16:45:50 +00:00
commit 4ca79e31ff
168 changed files with 773 additions and 715 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/2htdp/universe.ss
View File

@ -309,4 +309,4 @@
(on-new nu) (on-new nu)
(on-msg process) (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) (send bdc set-bitmap #f)
bitmap) 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")) (make-special-comment "comment"))
(super-instantiate ()) (super-instantiate ())
(inherit set-snipclass) (inherit set-snipclass)
(set-snipclass snipclass)))) (set-snipclass snipclass))))

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

@ -96,4 +96,4 @@
(if (not embedded-pos) (if (not embedded-pos)
(next-loop) (next-loop)
(values embedded embedded-pos)))] (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 frame: frame^))
(open (prefix handler: handler^)) (open (prefix handler: handler^))
(open (prefix scheme: scheme^)) (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 "chat-noir-unit.ss")
(define game-set "Puzzle Games") (define game-set "Puzzle Games")
(define compile-omit-files '("chat-noir.ss")) (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) (start 200 200)
(check-error (hangman-list reveal-list draw-next-part) (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>")

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

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

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

@ -68,9 +68,10 @@
(super-new))) (super-new)))
(define controller% (define controller%
(class (secondary-partition-mixin (class* (secondary-partition-mixin
(selection-manager-mixin (selection-manager-mixin
(mark-manager-mixin (mark-manager-mixin
(displays-manager-mixin (displays-manager-mixin
object%)))) object%))))
(controller<%>)
(super-new))) (super-new)))

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

@ -1,11 +1,10 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop) macro-debugger/util/class-iop)
(provide (all-defined-out)) (provide (all-defined-out))
;; displays-manager<%> ;; displays-manager<%>
(define-interface displays-manager<%> (define-interface displays-manager<%> ()
(;; add-syntax-display : display<%> -> void (;; add-syntax-display : display<%> -> void
add-syntax-display add-syntax-display
@ -13,7 +12,7 @@
remove-all-syntax-displays)) remove-all-syntax-displays))
;; selection-manager<%> ;; selection-manager<%>
(define-interface selection-manager<%> (define-interface selection-manager<%> ()
(;; selected-syntax : syntax/#f (;; selected-syntax : syntax/#f
set-selected-syntax set-selected-syntax
get-selected-syntax get-selected-syntax
@ -21,12 +20,15 @@
;; mark-manager<%> ;; mark-manager<%>
;; Manages marks, mappings from marks to colors ;; Manages marks, mappings from marks to colors
(define-interface mark-manager<%> (define-interface mark-manager<%> ()
(;; get-primary-partition : -> partition (;; get-primary-partition : -> partition
get-primary-partition)) get-primary-partition
;; reset-primary-partition : -> void
reset-primary-partition))
;; secondary-partition<%> ;; secondary-partition<%>
(define-interface secondary-partition<%> (define-interface secondary-partition<%> ()
(;; get-secondary-partition : -> partition<%> (;; get-secondary-partition : -> partition<%>
get-secondary-partition get-secondary-partition
@ -46,27 +48,15 @@
listen-identifier=?)) listen-identifier=?))
;; controller<%> ;; controller<%>
(define-interface/dynamic controller<%> (define-interface controller<%> (displays-manager<%>
(interface (displays-manager<%> selection-manager<%>
selection-manager<%> mark-manager<%>
mark-manager<%> secondary-partition<%>)
secondary-partition<%>)) ())
(add-syntax-display
remove-all-syntax-displays
set-selected-syntax
get-selected-syntax
listen-selected-syntax
get-primary-partition
get-secondary-partition
set-secondary-partition
listen-secondary-partition
get-identifier=?
set-identifier=?
listen-identifier=?))
;; host<%> ;; host<%>
(define-interface host<%> (define-interface host<%> ()
(;; get-controller : -> controller<%> (;; get-controller : -> controller<%>
get-controller get-controller
@ -74,7 +64,7 @@
add-keymap)) add-keymap))
;; display<%> ;; display<%>
(define-interface display<%> (define-interface display<%> ()
(;; refresh : -> void (;; refresh : -> void
refresh refresh
@ -94,7 +84,7 @@
get-range)) get-range))
;; range<%> ;; range<%>
(define-interface range<%> (define-interface range<%> ()
(;; get-ranges : datum -> (list-of (cons number number)) (;; get-ranges : datum -> (list-of (cons number number))
get-ranges get-ranges
@ -111,14 +101,14 @@
;; syntax-prefs<%> ;; syntax-prefs<%>
(define-interface syntax-prefs<%> (define-interface syntax-prefs<%> ()
(pref:width (pref:width
pref:height pref:height
pref:props-percentage pref:props-percentage
pref:props-shown?)) pref:props-shown?))
;; widget-hooks<%> ;; widget-hooks<%>
(define-interface widget-hooks<%> (define-interface widget-hooks<%> ()
(;; setup-keymap : -> void (;; setup-keymap : -> void
setup-keymap setup-keymap
@ -126,7 +116,7 @@
shutdown)) shutdown))
;; keymap-hooks<%> ;; keymap-hooks<%>
(define-interface keymap-hooks<%> (define-interface keymap-hooks<%> ()
(;; make-context-menu : -> context-menu<%> (;; make-context-menu : -> context-menu<%>
make-context-menu make-context-menu
@ -134,7 +124,7 @@
get-context-menu%)) get-context-menu%))
;; context-menu-hooks<%> ;; context-menu-hooks<%>
(define-interface context-menu-hooks<%> (define-interface context-menu-hooks<%> ()
(add-edit-items (add-edit-items
after-edit-items after-edit-items
add-selection-items add-selection-items
@ -146,15 +136,16 @@
;;---------- ;;----------
;; Convenience widget, specialized for displaying stx and not much else ;; Convenience widget, specialized for displaying stx and not much else
(define-interface syntax-browser<%> (define-interface syntax-browser<%> ()
(add-syntax (add-syntax
add-text add-text
add-error-text
add-clickback
add-separator add-separator
erase-all erase-all
select-syntax
get-text)) get-text))
(define-interface partition<%> (define-interface partition<%> ()
(;; get-partition : any -> number (;; get-partition : any -> number
get-partition get-partition

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

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

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

@ -21,7 +21,7 @@
;; widget% ;; widget%
;; A syntax widget creates its own syntax-controller. ;; A syntax widget creates its own syntax-controller.
(define widget% (define widget%
(class* object% (widget-hooks<%>) (class* object% (syntax-browser<%> widget-hooks<%>)
(init parent) (init parent)
(init-field config) (init-field config)

14
collects/macro-debugger/util/class-iop.ss
View File

@ -13,6 +13,7 @@
define: define:
lambda: lambda:
init: init:
init-field:
init-private:) init-private:)
;; Configuration ;; Configuration
@ -25,10 +26,13 @@
;; Defines NAME as an interface. ;; Defines NAME as an interface.
(define-syntax (define-interface stx) (define-syntax (define-interface stx)
(syntax-parse stx (syntax-parse stx
[(_ name:id (mname:id ...)) [(_ name:id (super:static-interface ...) (mname:id ...))
#'(define-interface/dynamic name (with-syntax ([((super-method ...) ...)
(let ([name (interface () mname ...)]) name) (map static-interface-members
(mname ...))])) (syntax->datum #'(super.value ...)))])
#'(define-interface/dynamic name
(let ([name (interface (super ...) mname ...)]) name)
(super-method ... ... mname ...)))]))
;; define-interface/dynamic SYNTAX ;; define-interface/dynamic SYNTAX
;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...)) ;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
@ -181,7 +185,7 @@
(syntax-parse stx (syntax-parse stx
[(_ init name:id iface:static-interface) [(_ init name:id iface:static-interface)
(with-syntax ([(name-internal) (generate-temporaries #'(name))]) (with-syntax ([(name-internal) (generate-temporaries #'(name))])
#'(begin (init (name name-internal)) #'(begin (init ((name-internal name)))
(void (check-object<:interface init: name-internal iface)) (void (check-object<:interface init: name-internal iface))
(define-syntax name (define-syntax name
(make-checked-binding (make-checked-binding

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

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

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

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

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

@ -1,50 +1,77 @@
#lang scheme/base #lang scheme/base
(require scheme/unit) (require macro-debugger/util/class-iop)
(provide (all-defined-out)) (provide (all-defined-out))
;; Signatures (define-interface widget<%> ()
(get-config
get-controller
get-macro-hiding-prefs
get-step-displayer
#; add-trace
(define-signature view^ add-deriv
(macro-stepper-frame%
macro-stepper-widget%
make-macro-stepper
go
go/deriv))
#; update/preserve-view
(define-signature view-base^ refresh/resynth
(base-frame%))
#; reset-primary-partition
(define-signature prefs^ remove-current-term
(pref:width duplicate-stepper
pref:height show-in-new-frame
pref:props-shown?
pref:props-percentage get-preprocess-deriv
pref:macro-hiding-mode get-show-macro?
pref:show-syntax-properties? ))
pref:show-hiding-panel?
pref:identifier=? (define-interface stepper-frame<%> ()
pref:show-rename-steps? (get-widget
pref:highlight-foci? get-controller
pref:highlight-frontier? add-obsoleted-warning))
pref:suppress-warnings?
pref:one-by-one? (define-interface hiding-prefs<%> ()
pref:extra-navigation? (add-show-identifier
pref:debug-catch-errors? add-hide-identifier
pref:force-letrec-transformation? 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% (define-interface director<%> ()
;; all fields are notify-box% objects (add-deriv
;; width new-stepper))
;; height
;; macro-hiding?
;; hide-primitives?
;; hide-libs?
;; show-syntax-properties?
;; show-hiding-panel?
;; show-rename-steps?
;; highlight-foci?

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

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

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

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

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

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

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

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/pretty scheme/pretty
scheme/gui scheme/gui
framework/framework framework/framework
@ -13,7 +14,7 @@
go) go)
(define macro-stepper-director% (define macro-stepper-director%
(class object% (class* object% (director<%>)
(define stepper-frames (make-hasheq)) (define stepper-frames (make-hasheq))
;; Flags is a subset(list) of '(no-obsolete no-new-traces) ;; Flags is a subset(list) of '(no-obsolete no-new-traces)
@ -27,23 +28,23 @@
(hash-for-each stepper-frames (hash-for-each stepper-frames
(lambda (stepper-frame flags) (lambda (stepper-frame flags)
(unless (memq 'no-obsolete flags) (unless (memq 'no-obsolete flags)
(send stepper-frame add-obsoleted-warning))))) (send: stepper-frame stepper-frame<%> add-obsoleted-warning)))))
(define/public (add-trace events) (define/public (add-trace events)
(hash-for-each stepper-frames (hash-for-each stepper-frames
(lambda (stepper-frame flags) (lambda (stepper-frame flags)
(unless (memq 'no-new-traces flags) (unless (memq 'no-new-traces flags)
(send (send stepper-frame get-widget) (send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
add-trace events))))) add-trace events)))))
(define/public (add-deriv deriv) (define/public (add-deriv deriv)
(hash-for-each stepper-frames (hash-for-each stepper-frames
(lambda (stepper-frame flags) (lambda (stepper-frame flags)
(unless (memq 'no-new-traces flags) (unless (memq 'no-new-traces flags)
(send (send stepper-frame get-widget) (send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
add-deriv deriv))))) add-deriv deriv)))))
(define/public (new-stepper [flags '()]) (define/public (new-stepper [flags '()])
(define stepper-frame (new-stepper-frame)) (define stepper-frame (new-stepper-frame))
(define stepper (send stepper-frame get-widget)) (define stepper (send: stepper-frame stepper-frame<%> get-widget))
(send stepper-frame show #t) (send stepper-frame show #t)
(add-stepper! stepper-frame flags) (add-stepper! stepper-frame flags)
stepper) stepper)
@ -64,31 +65,6 @@
(define (go stx) (define (go stx)
(define director (new macro-stepper-director%)) (define director (new macro-stepper-director%))
(define stepper (send director new-stepper)) (define stepper (send: director director<%> new-stepper))
(send director add-deriv (trace stx)) (send: director director<%> add-deriv (trace stx))
(void)) (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 f (new frame% [label "test"]))
(define c (new close-icon% [parent f] [callback (λ () (printf "hi\n"))])) (define c (new close-icon% [parent f] [callback (λ () (printf "hi\n"))]))
(define gb (new grow-box-spacer-pane% [parent f])) (define gb (new grow-box-spacer-pane% [parent f]))
(send f show #t)) (send f show #t))

2
collects/mzlib/contract.ss
View File

@ -85,4 +85,4 @@
(define (flat-contract/predicate? pred) (define (flat-contract/predicate? pred)
(or (flat-contract? pred) (or (flat-contract? pred)
(and (procedure? 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 ordinary arguments, its keywords, the values of the keywords, and a
number indicating the depth of the call. 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 trusted root certificates; @scheme[#f] disables verification of
peer server certificates} 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.} 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)} @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 true)}
@item{@(scheme false)} @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)} @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)} @item{@(scheme false)}
} }

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

@ -920,4 +920,4 @@ reflects the (broken) spec).
;; timing test ;; timing test
#; #;
(time (run-tests) (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))) (semaphore-post (semaphore x)))
(begin (semaphore-wait (semaphore x)) (begin (semaphore-wait (semaphore x))
(set! y (cons 2 y)) (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) (define (show term)
(traces reductions term #:pred (pred 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)))) (term (λ (z1 x1) (λ (x) z))))
(test-equal (term (subst (x 1 (λ (x x) x)))) (test-equal (term (subst (x 1 (λ (x x) x))))
(term (λ (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?)]) [initial-char-width (parameter/c number?)])
(provide reduction-steps-cutoff (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" (provide (all-from-out "reduction-semantics.ss"
"gui.ss" "gui.ss"
"pict.ss")) "pict.ss"))
(provide render-language) (provide render-language)

2
collects/redex/pict.ss
View File

@ -102,4 +102,4 @@
[lw->pict [lw->pict
(-> (or/c (listof symbol?) compiled-lang?) lw? pict?)] (-> (or/c (listof symbol?) compiled-lang?) lw? pict?)]
[render-lw [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) (,(* (term number_1) 2) word)
dup)) dup))
'(1 word) '(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)])) [else (for-each find/lw e)]))
(find/e in-lws) (find/e in-lws)
lws) lws)

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

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

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

@ -50,4 +50,4 @@
(render-language x0-10) (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 (provide relation-coverage
covered-cases covered-cases
(rename-out [fresh-coverage make-coverage]) (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) (current-continuation-marks)
(list (id/depth-id x) (id/depth-id (car dups))))))) (list (id/depth-id x) (id/depth-id (car dups)))))))
(not same-id?))) (not same-id?)))
(loop (cdr dups))))])))) (loop (cdr dups))))]))))

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

@ -859,4 +859,4 @@ To do a better job of not generating programs with free variables,
generation-decisions) generation-decisions)
(provide/contract (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 #lang scheme/base
(require (lib "mred.ss" "mred") (require scheme/gui/base
(lib "class.ss") scheme/class
(lib "pretty.ss") framework
(lib "framework.ss" "framework") scheme/pretty
"matcher.ss") "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))))))
(define/pubment (on-width-changed w) (inner (void) on-width-changed w)) (provide reflowing-snip<%>
size-editor-snip%
(define/public (format-expr) size-text%
(let* ([text (get-editor)] default-pretty-printer
[port (open-output-text-editor text)]) initial-char-width
(send text begin-edit-sequence) resizing-pasteboard-mixin)
(when (is-a? text color:text<%>)
(send text thaw-colorer)) (define initial-char-width (make-parameter 30))
(send text set-styles-sticky #f)
(send text erase) (define (default-pretty-printer v port w spec)
(real-pp expr port char-width text) (parameterize ([pretty-print-columns w]
(unless (zero? (send text last-position)) [pretty-print-size-hook
(when (char=? #\newline (send text get-character (- (send text last-position) 1))) (λ (val display? op)
(send text delete (- (send text last-position) 1) (send text last-position)))) (cond
(when (is-a? text color:text<%>) [(hole? val) 4]
(send text freeze-colorer)) [(eq? val 'hole) 6]
(send text end-edit-sequence))) [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 upper-hp (new horizontal-panel% [parent dp]))
(define lower-hp (new horizontal-panel% [alignment '(center center)] [parent f] [stretchable-height #f])) (define lower-hp (new horizontal-panel% [alignment '(center center)] [parent f] [stretchable-height #f]))
(define pb (new columnar-pasteboard% (define pb (new columnar-pasteboard%
[shrink-down? #f]
[moved (λ (a b c d) [moved (λ (a b c d)
(when (procedure? moved) (when (procedure? moved)
(moved a b c d)))])) (moved a b c d)))]))
@ -801,7 +800,7 @@ todo:
flat-to-remove) flat-to-remove)
(for-each (λ (x) (insert x)) flat-to-insert))) (for-each (λ (x) (insert x)) flat-to-insert)))
(inherit get-admin move-to resize) (inherit get-admin move-to)
(define/public (update-heights) (define/public (update-heights)
(let ([admin (get-admin)]) (let ([admin (get-admin)])
(let-values ([(w h) (get-view-size)]) (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. ;; 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)] (let* ([snip (car column)]
[sw (get-snip-width snip)] [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) (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)))] (loop (cdr columns) (+ x sw)))]
[else [else
;; otherwise, we make all of the snips fit into the visible area ;; otherwise, we make all of the snips fit into the visible area
@ -838,16 +839,39 @@ todo:
0 0
1))]) 1))])
(move-to snip x y) (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) (loop (cdr snips)
(if (zero? extra-space) (if (zero? extra-space)
0 0
(- extra-space 1)) (- extra-space 1))
(+ y h) (+ y h)
(max widest sw)))]))]) (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) (loop (cdr columns)
(+ x widest)))]))]))))) (+ 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) (inherit get-snip-location)
(define/public (get-snip-width snip) (define/public (get-snip-width snip)
(let ([lb (box 0)] (let ([lb (box 0)]

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

@ -76,4 +76,4 @@
(term (((metafun x) y) ...)))) (term (((metafun x) y) ...))))
'((whatever 4) (whatever 5) (whatever 6))) '((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] ...) (with-syntax ([x rhs] ...)
(begin body1 body2 ...)))] (begin body1 body2 ...)))]
[(_ x) [(_ 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 ;; should cache the count of new snips -- dont
;; use `count-snips'; use something associated with the ;; use `count-snips'; use something associated with the
;; equal hash-table ;; equal hash-table
#lang scheme
(require mrlib/graph (require mrlib/graph
"reduction-semantics.ss" "reduction-semantics.ss"
"matcher.ss" "matcher.ss"
"size-snip.ss" "size-snip.ss"
"dot.ss" "dot.ss"
scheme/gui/base scheme/gui/base
scheme/class
scheme/file
framework) framework)
(preferences:set-default 'plt-reducer:show-bottom #t boolean?) (preferences:set-default 'plt-reducer:show-bottom #t boolean?)
@ -139,12 +141,83 @@
#:scheme-colors? scheme-colors? #:scheme-colors? scheme-colors?
#:colors colors #:colors colors
#:layout layout)]) #:layout layout)])
(let ([ps-setup (make-object ps-setup%)]) (print-to-ps graph-pb filename)))
(send ps-setup copy-from (current-ps-setup))
(send ps-setup set-file filename) (define (print-to-ps graph-pb filename)
(send ps-setup set-mode 'file) (let ([admin (send graph-pb get-admin)]
(parameterize ([current-ps-setup ps-setup]) [printing-admin (new printing-editor-admin%)])
(send graph-pb print #f #f 'postscript #f #f #t))))) (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 (define (traces reductions pre-exprs
#:multiple? [multiple? #f] #:multiple? [multiple? #f]
@ -157,7 +230,7 @@
(define exprs (if multiple? pre-exprs (list pre-exprs))) (define exprs (if multiple? pre-exprs (list pre-exprs)))
(define main-eventspace (current-eventspace)) (define main-eventspace (current-eventspace))
(define saved-parameterization (current-parameterization)) (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% () (define f (instantiate red-sem-frame% ()
(label "PLT Redex Reduction Graph") (label "PLT Redex Reduction Graph")
(style '(toolbar-button)) (style '(toolbar-button))
@ -275,7 +348,7 @@
(let loop ([snip (send graph-pb find-first-snip)]) (let loop ([snip (send graph-pb find-first-snip)])
(when snip (when snip
(when (is-a? snip reflowing-snip<%>) (when (is-a? snip reflowing-snip<%>)
(send snip shrink-down)) (send snip reflow-program))
(loop (send snip next)))))) (loop (send snip next))))))
;; fill-out : (listof X) (listof X) -> (listof X) ;; fill-out : (listof X) (listof X) -> (listof X)
@ -338,7 +411,7 @@
(set! col (+ x-spacing (find-rightmost-x graph-pb)))) (set! col (+ x-spacing (find-rightmost-x graph-pb))))
(begin0 (begin0
(insert-into col y graph-pb new-snips) (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 graph-pb end-edit-sequence)
(send status-message set-label (send status-message set-label
(string-append (term-count (count-snips)) "...")))))]) (string-append (term-count (count-snips)) "...")))))])
@ -469,7 +542,7 @@
null))) null)))
(out-of-dot-state) ;; make sure the state is initialized right (out-of-dot-state) ;; make sure the state is initialized right
(insert-into init-rightmost-x 0 graph-pb frontier) (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)) (set-font-size (initial-font-size))
(cond (cond
[no-show-frame? [no-show-frame?
@ -507,6 +580,10 @@
(define graph-pasteboard% (define graph-pasteboard%
(class (resizing-pasteboard-mixin (class (resizing-pasteboard-mixin
(graph-pasteboard-mixin pasteboard%)) (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 dot-callback #f)
(define/public (set-dot-callback cb) (set! dot-callback cb)) (define/public (set-dot-callback cb) (set! dot-callback cb))
(define/override (draw-edges dc left top right bottom dx dy) (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-move? evt) mobile?)
(define/augment (can-interactive-resize? 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))) (super-new)))
(define graph-editor-snip% (define graph-editor-snip%
@ -578,7 +666,7 @@
(super-new))) (super-new)))
(define program-text% (define program-text%
(class scheme:text% (class size-text%
(define bad-color #f) (define bad-color #f)
(define/public (set-bad color) (set! bad-color color)) (define/public (set-bad color) (set! bad-color color))
@ -688,6 +776,7 @@
(pp pp) (pp pp)
(expr expr))]) (expr expr))])
(send text set-autowrap-bitmap #f) (send text set-autowrap-bitmap #f)
(send text set-max-width 'none)
(send text freeze-colorer) (send text freeze-colorer)
(send text stop-colorer (not scheme-colors?)) (send text stop-colorer (not scheme-colors?))
(send es format-expr) (send es format-expr)

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

@ -1,3 +1,3 @@
(module underscore-allowed mzscheme (module underscore-allowed mzscheme
(provide underscore-allowed) (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|. that @|pattern|.
} }
@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern matches @item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern
what the embedded @pattern matches, and then the guard expression is matches what the embedded @pattern matches, and then the guard
evaluated. If it returns @scheme[#f], the @pattern fails to match, and if it expression is evaluated. If it returns @scheme[#f], the @pattern fails
returns anything else, the @pattern matches. In addition, any to match, and if it returns anything else, the @pattern matches. Any
occurrences of `name' in the @pattern are bound using @scheme[term-let] occurrences of `name' in the @pattern (including those implicitly
in the guard. 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 @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?] [relation reduction-relation?]
[property (-> any/c any/c)] [property (-> any/c any/c)]
[#:attempts attempts natural-number/c 100]) [#:attempts attempts natural-number/c 100])
(or/c true/c void?)]{ void?]{
Tests a @scheme[relation] as follows: for each case of @scheme[relation], Tests a @scheme[relation] as follows: for each case of @scheme[relation],
@scheme[check-reduction-relation] generates @scheme[attempts] random @scheme[check-reduction-relation] generates @scheme[attempts] random
terms that match that case's left-hand side and applies @scheme[property] 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-pen-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[dark-brush-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-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?]{ @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)))] (one-of/c #t (void)))]
[relation-coverage (parameter/c (or/c false/c coverage?))] [relation-coverage (parameter/c (or/c false/c coverage?))]
[make-coverage (-> reduction-relation? 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 "13jan2009") #lang scheme/base (provide stamp) (define stamp "14jan2009")

2
collects/scheme/private/contract-guts.ss
View File

@ -515,4 +515,4 @@
#:property name-prop (λ (ctc) (predicate-contract-name ctc)) #:property name-prop (λ (ctc) (predicate-contract-name ctc))
#:property flat-prop (λ (ctc) (predicate-contract-pred ctc))) #:property flat-prop (λ (ctc) (predicate-contract-pred ctc)))
(define (build-flat-contract name pred) (make-predicate-contract name pred)) (define (build-flat-contract name pred) (make-predicate-contract name pred))

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

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

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

@ -240,4 +240,4 @@
(list (make-element 'italic (list i)))])] (list (make-element 'italic (list i)))])]
[(eq? i 'rsquo) (list 'prime)] [(eq? i 'rsquo) (list 'prime)]
[else (list i)]))) [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. ") @(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) (define (edsnipsize a b c)
@elem{An @scheme[editor-snip%] normally stretches to wrap around the size @elem{An @scheme[editor-snip%] normally stretches to wrap around the size
of the editor it contains. This method #1 of the snip of the editor it contains. This method @|a| of the snip
(and if the editor is #2, #3).}) (and if the editor is @|b|, @|c|).})
(define (edsnipmax n) (define (edsnipmax n)
(edsnipsize @elem{limits the @|n|} (edsnipsize @elem{limits the @|n|}
@elem{larger} @elem{larger}

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

@ -2,4 +2,4 @@
(require scribble/extract) (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) (qualifier)
(first-ec #t qualifier (if (not expression)) #f) )) (first-ec #t qualifier (if (not expression)) #f) ))
) )

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

@ -35,4 +35,4 @@
(raise-syntax-error (raise-syntax-error
'define-generator 'define-generator
"expected either (define-generator <id> <proc>) or (define-generator (<id1> <id2>) <body> ... , got: " "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 ; of a generator clause as input. For example
; #'(:list x (list 1 2 3)). The function form->loop ; #'(:list x (list 1 2 3)). The function form->loop
; returns a loop structure. ; 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: " "expected (:while <generator> <expr>) got: "
form-stx)])) form-stx)]))
) )

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

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

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

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

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

@ -13,4 +13,4 @@
by the chosen frame by the chosen frame
(bound) : all bound vars (bound) : all bound vars
(v <x>) : value of a named variable (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)] . -> . simple-rel-to-module-path-v/c)]
[collapse-module-path-index ((or/c symbol? module-path-index?) [collapse-module-path-index ((or/c symbol? module-path-index?)
rel-to-module-path-v/c 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) (define (module-path-v? v)
(or (path? v) (or (path? v)
(module-path? v))) (module-path? v)))

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

@ -76,4 +76,4 @@
;; ------------------------------- ;; -------------------------------
(command-line #:args (n) (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}}}" {fun main {foo} {call foo foo}}}"
1)) 1))
) )

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

@ -219,4 +219,4 @@ Evaluation rules:
{fun {x} {fun {y} {+ x y}}}} {fun {x} {fun {y} {+ x y}}}}
123}") 123}")
=> 124) => 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) (apply (case-lambda: (([x : Number] . [y : Number ... a]) x)
(([x : String] [y : String] . [z : String *]) 0) (([x : String] [y : String] . [z : String *]) 0)
([y : 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)) (define (f3 x y) (+ x y))
(: f2 (case-lambda (Number * -> Number))) (: 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)))) (: g (All (b ...) ( -> (b ... b -> Integer))))
(define (g) (lambda xs 0)) (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)) (: f3 (Integer Integer -> Integer))
(define (f3 x . z) (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) (define (g x y) y)
(g "foo" (list "foo"))) (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)) (: f (Foo -> String))
(define (f x) (string-append x)) (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)) (define (f . x) (+ 1 2))
(: f4 (case-lambda (Integer * -> Integer) (Number * -> Number))) (: 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) y)
(plambda: (a ...) ([x : Number] . [y : Number ... a]) (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 c
(apply f (apply f
(apply (inst fold-left c a b ... b) f c (cdr as) (map cdr bss)) (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) 3 4 5)
(fold-left (lambda: ([a : (Listof Integer)] [c : Integer]) (cons c a)) null (list 3 4 5 6)) (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 root
)) ))
) )

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

@ -108,4 +108,3 @@
(= 0 (list-length '())) (= 0 (list-length '()))
(= 2 (list-length '(1 2))) (= 2 (list-length '(1 2)))
(= 3 (list-length '(1 2 (1 2 3 4)))) (= 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 ...) () (lambda: [ys : a ... a] 3)))
#;((plambda: (a ...) [xs : a ... 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)) (apply f as))
fs)))) fs))))
(inst map-with-funcs Integer Integer Integer Integer) (inst map-with-funcs Integer Integer Integer Integer)

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

@ -17,4 +17,4 @@
(define (g x) 3) (define (g x) 3)
|# |#

2
collects/tests/typed-scheme/succeed/star-sizes.ss
View File

@ -3,4 +3,4 @@
(: f (All (a) ((Integer a * -> Integer) -> Integer))) (: f (All (a) ((Integer a * -> Integer) -> Integer)))
(define (f g) 0) (define (f g) 0)
(f +) (f +)

2
collects/tests/typed-scheme/succeed/unholy-terror.ss
View File

@ -62,4 +62,4 @@
(map (lambda: ([f : (a ... a -> b)]) (map (lambda: ([f : (a ... a -> b)])
(apply f as)) (apply f as))
fs))) fs)))
(map-with-funcs + - * /) (map-with-funcs + - * /)

2
collects/tests/typed-scheme/succeed/values-dots.ss
View File

@ -27,4 +27,4 @@
(((inst map-with-funcs Integer Integer) (((inst map-with-funcs Integer Integer)
(lambda: ([x : Integer] [y : Integer]) (+ x y)) (lambda: ([x : Integer] [y : Integer]) (+ x y))
(lambda: ([x : Integer] [y : Integer]) (- x y))) (lambda: ([x : Integer] [y : Integer]) (- x y)))
3 4) 3 4)

2
collects/tests/typed-scheme/succeed/with-handlers.ss
View File

@ -7,4 +7,4 @@
(define: (is-happiness-a-warm-gun?) : Boolean (define: (is-happiness-a-warm-gun?) : Boolean
(with-handlers ([integer? (lambda: ([x : Any]) #t)]) (with-handlers ([integer? (lambda: ([x : Any]) #t)])
(f 42) (f 42)
#t)) #t))

2
collects/tests/typed-scheme/unit-tests/random-testing.ss
View File

@ -67,4 +67,4 @@
(go 0) (go 0)
;(generate (base-gen 1)) ;(generate (base-gen 1))

2
collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
View File

@ -119,4 +119,4 @@
; Comment in to run tests ; Comment in to run tests
#;(require #;(planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2)) #;(require #;(planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2))
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))) (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
#;(test/text-ui dispatch-servlets-tests) #;(test/text-ui dispatch-servlets-tests)

2
collects/tests/web-server/dispatchers/filesystem-map-test.ss
View File

@ -78,4 +78,4 @@
(test-url->path test-filter-map (build-path "dispatchers/filesystem-map.html"))))) (test-url->path test-filter-map (build-path "dispatchers/filesystem-map.html")))))
(test-case "Allows content after w/ valid" (test-case "Allows content after w/ valid"
(test-url->path test-filter-valid-map (build-path "dispatchers/filesystem-map.ss/extra/info") (test-url->path test-filter-valid-map (build-path "dispatchers/filesystem-map.ss/extra/info")
#:expected (build-path "dispatchers/filesystem-map.ss")))))) #:expected (build-path "dispatchers/filesystem-map.ss"))))))

2
collects/tests/web-server/lang-test.ss
View File

@ -565,4 +565,4 @@
(define-values (point i) (values #t 1)) (define-values (point i) (values #t 1))
i))))))) i)))))))
)) ))

2
collects/tests/web-server/lang/abort-resume-test.ss
View File

@ -204,4 +204,4 @@
; XXX test dispatch ; XXX test dispatch
)) ))

2
collects/tests/web-server/servlet-env/env.ss
View File

@ -25,4 +25,4 @@
,(number->string (+ (request-number "first") (request-number "second"))))))) ,(number->string (+ (request-number "first") (request-number "second")))))))
(serve/servlet start (serve/servlet start
#:servlet-path "/") #:servlet-path "/")

2
collects/typed-scheme/infer/constraint-structs.ss
View File

@ -48,4 +48,4 @@
(struct dcon-exact ([fixed (listof c?)] [rest c?])) (struct dcon-exact ([fixed (listof c?)] [rest c?]))
(struct dcon-dotted ([type c?] [bound symbol?])) (struct dcon-dotted ([type c?] [bound symbol?]))
(struct dmap ([map (hashof symbol? (or/c dcon? dcon-exact? dcon-dotted?))])) (struct dmap ([map (hashof symbol? (or/c dcon? dcon-exact? dcon-dotted?))]))
(struct cset ([maps (listof (cons/c (hashof symbol? c?) dmap?))]))) (struct cset ([maps (listof (cons/c (hashof symbol? c?) dmap?))])))

2
collects/typed-scheme/infer/dmap.ss
View File

@ -63,4 +63,4 @@
(define (dmap-meet dm1 dm2) (define (dmap-meet dm1 dm2)
(make-dmap (make-dmap
(hash-union (dmap-map dm1) (dmap-map dm2) (hash-union (dmap-map dm1) (dmap-map dm2)
(lambda (k dc1 dc2) (dcon-meet dc1 dc2))))) (lambda (k dc1 dc2) (dcon-meet dc1 dc2)))))

2
collects/typed-scheme/infer/infer-dummy.ss
View File

@ -5,4 +5,4 @@
(define infer-param (make-parameter (lambda e (int-err "infer not initialized")))) (define infer-param (make-parameter (lambda e (int-err "infer not initialized"))))
(define (unify X S T) ((infer-param) X S T (make-Univ) null)) (define (unify X S T) ((infer-param) X S T (make-Univ) null))
(provide unify infer-param) (provide unify infer-param)

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