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

.

Browse Source 
original commit: cf5bf95a2571e10f79d4fd39bb5d61bcac8c0365
This commit is contained in:
Robby Findler 2005-01-29 20:42:14 +00:00
parent 3261add039
commit 5883db2475
34 changed files with 1001 additions and 1008 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/drscheme/private/syntax-browser.ss
View File

@ -80,18 +80,18 @@ needed to really make this work:
(send text last-position)))
(let ([range-pretty-print-pre-hook
(lambda (x v)
(λ (x v)
(hash-table-put! range-start-ht x (send output-text last-position)))]
[range-pretty-print-post-hook
(lambda (x port)
(let ([range-start (hash-table-get range-start-ht x (lambda () #f))])
(λ (x port)
(let ([range-start (hash-table-get range-start-ht x (λ () #f))])
(when range-start
(hash-table-put! range-ht x
(cons
(cons
range-start
(send output-text last-position))
(hash-table-get range-ht x (lambda () null)))))))])
(hash-table-get range-ht x (λ () null)))))))])
(parameterize ([current-output-port output-port]
[pretty-print-pre-print-hook range-pretty-print-pre-hook]
[pretty-print-post-print-hook range-pretty-print-post-hook]
@ -116,7 +116,7 @@ needed to really make this work:
(unless (null? properties)
(insert/big "Known properties\n")
(for-each
(lambda (prop) (show-property stx prop))
(λ (prop) (show-property stx prop))
properties))))
(define/private (render-mpi mpi)
@ -140,7 +140,7 @@ needed to really make this work:
(define/private (piece-of-info label info)
(let ([small-newline
(lambda (port text)
(λ (port text)
(let ([before-newline (send text last-position)])
(newline port)
(send info-text change-style small-style before-newline (+ before-newline 1))))])
@ -152,12 +152,12 @@ needed to really make this work:
;; but won't work without built-in support for
;; editors as output ports
(parameterize ([pretty-print-size-hook
(lambda (val d/p port)
(λ (val d/p port)
(if (is-a? val syntax-snip%)
(+ (string-length (format "~a" (send val get-syntax))) 2)
#f))]
[pretty-print-print-hook
(lambda (val d/p port)
(λ (val d/p port)
(send info-text insert (send val copy)
(send info-text last-position)
(send info-text last-position)))])
@ -276,28 +276,28 @@ needed to really make this work:
(apply append
(hash-table-map
range-ht
(lambda (k vs)
(λ (k vs)
(map
(lambda (v) (make-range k (car v) (cdr v)))
(λ (v) (make-range k (car v) (cdr v)))
vs))))
(lambda (x y)
(λ (x y)
(>= (- (range-end x) (range-start x))
(- (range-end y) (range-start y)))))])
(for-each
(lambda (range)
(λ (range)
(let* ([obj (range-obj range)]
[stx (hash-table-get stx-ht obj (lambda () #f))]
[stx (hash-table-get stx-ht obj (λ () #f))]
[start (range-start range)]
[end (range-end range)])
(when (syntax? stx)
(send output-text set-clickback start end
(lambda (_1 _2 _3)
(λ (_1 _2 _3)
(show-range stx start end))))))
ranges)
(send outer-t insert (new turn-snip%
[on-up (lambda () (hide-details))]
[on-down (lambda () (show-details))]))
[on-up (λ () (hide-details))]
[on-down (λ () (show-details))]))
(send outer-t insert (format "~s\n" main-stx))
(send outer-t insert inner-es)
(make-modern outer-t)
@ -323,7 +323,7 @@ needed to really make this work:
(k (void)))
(let* ([rng (car ranges)]
[obj (hash-table-get stx-ht (range-obj rng)
(lambda ()
(λ ()
(k (void))))])
(show-range obj (range-start rng) (range-end rng)))))
@ -478,7 +478,7 @@ needed to really make this work:
ht)))
(define (syntax-properties stx)
(let ([is-property? (lambda (prop) (syntax-property stx prop))])
(let ([is-property? (λ (prop) (syntax-property stx prop))])
(filter is-property?
'(inferred-name
bound-in-source
@ -497,7 +497,7 @@ needed to really make this work:
(define (make-text-port text)
(make-output-port #f
always-evt
(lambda (s start end flush? breaks?)
(λ (s start end flush? breaks?)
(send text insert (bytes->string/utf-8 (subbytes s start end))
(send text last-position)
(send text last-position))
@ -517,7 +517,7 @@ needed to really make this work:
(span ,(syntax-span stx))
(original? ,(syntax-original? stx))
(properties
,@(map (lambda (x) `(,x ,(marshall-object (syntax-property stx x))))
,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x))))
(syntax-property-symbol-keys stx)))
(contents
,(marshall-object (syntax-e stx)))))
@ -573,7 +573,7 @@ needed to really make this work:
[else stx]))
(define (unmarshall-object obj)
(let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))])
(let ([unknown (λ () (string->symbol (format "unknown: ~s" obj)))])
(if (and (pair? obj)
(symbol? (car obj)))
(case (car obj)

2
collects/framework/collapsed-snipclass.ss
View File

@ -11,7 +11,7 @@
(define/public (read-special file line col pos)
(let ([text (make-object text%)])
(for-each
(lambda (s) (send text insert (send s copy)
(λ (s) (send text insert (send s copy)
(send text last-position)
(send text last-position)))
saved-snips)

2
collects/framework/decorated-editor-snip.ss
View File

@ -188,7 +188,7 @@
(define/public (make-editor) (make-object text%))
(define/override write
(lambda (stream-out)
(λ (stream-out)
(send (get-editor) write-to-file stream-out 0 'eof)))
(define/override (copy)

10
collects/framework/framework.ss
View File

@ -232,9 +232,9 @@
((union string? (cons/c string? (listof string?)))
((is-a?/c area-container-window<%>)
. ->d .
(lambda (parent)
(let ([children (map (lambda (x) x) (send parent get-children))])
(lambda (child)
(λ (parent)
(let ([children (map (λ (x) x) (send parent get-children))])
(λ (child)
(and (is-a? child area-container-window<%>)
(andmap eq?
(append children (list child))
@ -747,7 +747,7 @@
((-> (is-a?/c frame:editor<%>)))
(union false/c (is-a?/c frame:editor<%>)))
((filename)
((make-default (lambda () ((handler:current-create-new-window) filename)))))
((make-default (λ () ((handler:current-create-new-window) filename)))))
"This function creates a frame or re-uses an existing frame to edit a file. "
""
"If the preference \\scheme{'framework:open-here} is set to \\scheme{#t},"
@ -797,7 +797,7 @@
""
"The default setting is this:"
"\\begin{schemedisplay}"
"(lambda (filename)"
"(λ (filename)"
" (let ([frame (make-object frame:text-info-file% filename)])"
" (send frame show #t)"
" frame))"

30
collects/framework/gui-utils.ss
View File

@ -17,9 +17,9 @@
(string?
(and/c number? positive?)
. ->d .
(lambda (str size)
(λ (str size)
(and/c string?
(lambda (str)
(λ (str)
((string-length str) . <= . size)))))
(str size)
"Constructs a string whose size is less"
@ -116,8 +116,8 @@
"(let ([close-down"
" (gui-utils:delay-action"
" 2"
" (lambda () .. init watch cursor ...)"
" (lambda () .. close watch cursor ...))])"
" (λ () .. init watch cursor ...)"
" (λ () .. close watch cursor ...))])"
" ;; .. do action ..."
" (close-down))"
"\\end{schemedisplay}"
@ -331,13 +331,13 @@
cancel-callback
[confirm-str (string-constant ok)]
[cancel-str (string-constant cancel)])
(let ([confirm (lambda ()
(let ([confirm (λ ()
(instantiate button% ()
(parent parent)
(callback confirm-callback)
(label confirm-str)
(style '(border))))]
[cancel (lambda ()
[cancel (λ ()
(instantiate button% ()
(parent parent)
(callback cancel-callback)
@ -366,7 +366,7 @@
(define next-untitled-name
(let ([n 1])
(lambda ()
(λ ()
(begin0
(cond
[(= n 1) (string-constant untitled)]
@ -384,19 +384,19 @@
(local-busy-cursor #f thunk delay)))
(define delay-action
(lambda (delay-time open close)
(λ (delay-time open close)
(let ([semaphore (make-semaphore 1)]
[open? #f]
[skip-it? #f])
(thread
(lambda ()
(λ ()
(sleep delay-time)
(semaphore-wait semaphore)
(unless skip-it?
(set! open? #t)
(open))
(semaphore-post semaphore)))
(lambda ()
(λ ()
(semaphore-wait semaphore)
(set! skip-it? #t)
(when open?
@ -411,21 +411,21 @@
(let* ([old-cursor #f]
[cursor-off void])
(dynamic-wind
(lambda ()
(λ ()
(set! cursor-off
(delay-action
delay
(lambda ()
(λ ()
(if win
(begin (set! old-cursor (send win get-cursor))
(send win set-cursor watch))
(begin-busy-cursor)))
(lambda ()
(λ ()
(if win
(send win set-cursor old-cursor)
(end-busy-cursor))))))
(lambda () (thunk))
(lambda () (cursor-off))))])))
(λ () (thunk))
(λ () (cursor-off))))])))
(define unsaved-warning
(opt-lambda (filename action-anyway (can-save-now? #f) (parent #f))

6
collects/framework/keybinding-lang.ss
View File

@ -31,16 +31,16 @@
(format "~a:~a.~a" src line col)
(format "~a:~a" src pos))])
(send #%keymap add-function name
(lambda (x y)
(λ (x y)
(let ([end-edit-sequence
(lambda ()
(λ ()
(when (is-a? x editor<%>)
(let loop ()
(when (send x in-edit-sequence?)
(send x end-edit-sequence)
(loop)))))])
(with-handlers ([exn:fail?
(lambda (x)
(λ (x)
(end-edit-sequence)
(message-box (string-constant drscheme)
(format (string-constant user-defined-keybinding-error)

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

@ -11,7 +11,7 @@
(define current-app-name (make-parameter
"MrEd"
(lambda (x)
(λ (x)
(unless (string? x)
(error 'current-app-name
"the app name must be a string"))

24
collects/framework/private/autosave.ss
View File

@ -57,7 +57,7 @@
(when (file-exists? autosave-toc-filename)
(copy-file autosave-toc-filename autosave-toc-save-filename))
(call-with-output-file autosave-toc-filename
(lambda (port)
(λ (port)
(write new-name-mapping port))
'truncate
'text))))
@ -115,13 +115,13 @@
(define (main)
(when (file-exists? autosave-toc-filename)
;; Load table from file, and check that the file was not corrupted
(let* ([table (let ([v (with-handlers ([exn:fail? (lambda (x) null)])
(let* ([table (let ([v (with-handlers ([exn:fail? (λ (x) null)])
(call-with-input-file autosave-toc-filename read))]
[path? (lambda (x)
[path? (λ (x)
(and (string? x)
(absolute-path? x)))])
(if (and (list? v)
(andmap (lambda (i)
(andmap (λ (i)
(and (list? i)
(= 2 (length i))
(or (not (car i))
@ -132,7 +132,7 @@
null))]
;; assume that the autosave file was deleted due to the file being saved
[filtered-table
(filter (lambda (x) (file-exists? (cadr x))) table)])
(filter (λ (x) (file-exists? (cadr x))) table)])
(unless (null? filtered-table)
(let* ([f (new final-frame%
(label (string-constant recover-autosave-files-frame-title)))]
@ -155,7 +155,7 @@
(make-object button%
(string-constant autosave-done)
vp
(lambda (x y)
(λ (x y)
(when (send f can-close?)
(send f on-close)
(send f show #f))))
@ -181,7 +181,7 @@
;; -> void
;; adds in a line to the overview table showing this pair of files.
(define (add-table-line area-container parent)
(lambda (table-entry)
(λ (table-entry)
(letrec ([orig-file (car table-entry)]
[backup-file (cadr table-entry)]
[hp (new horizontal-panel%
@ -210,13 +210,13 @@
(parent msg2-panel))]
[details
(make-object button% (string-constant autosave-details) hp
(lambda (x y)
(λ (x y)
(show-files table-entry)))]
[delete
(make-object button%
(string-constant autosave-delete-button)
hp
(lambda (delete y)
(λ (delete y)
(when (delete-autosave table-entry)
(disable-line)
(send msg2 set-label (string-constant autosave-deleted)))))]
@ -224,14 +224,14 @@
(make-object button%
(string-constant autosave-recover)
hp
(lambda (recover y)
(λ (recover y)
(let ([filename-result (recover-file parent table-entry)])
(when filename-result
(disable-line)
(send msg2 set-label (string-constant autosave-recovered!))
(send msg1 set-label filename-result)))))]
[disable-line
(lambda ()
(λ ()
(send recover enable #f)
(send details enable #f)
(send delete enable #f))])
@ -252,7 +252,7 @@
(string-constant warning)
#f)
(with-handlers ([exn:fail?
(lambda (exn)
(λ (exn)
(message-box
(string-constant warning)
(format (string-constant autosave-error-deleting)

10
collects/framework/private/canvas.ss
View File

@ -25,7 +25,7 @@
(define color-mixin
(mixin (basic<%>) (color<%>)
(define callback (lambda (p v) (set-canvas-background v)))
(define callback (λ (p v) (set-canvas-background v)))
(super-new)
(inherit set-canvas-background)
(set-canvas-background (preferences:get 'framework:basic-canvas-background))
@ -89,12 +89,12 @@
[get-width
(let ([bl (box 0)]
[br (box 0)])
(lambda (s)
(λ (s)
(send edit get-snip-location s bl #f #f)
(send edit get-snip-location s br #f #t)
(- (unbox br) (unbox bl))))]
[calc-after-width
(lambda (s)
(λ (s)
(+ 4 ;; this is compensate for an autowrapping bug
(let loop ([s s])
(cond
@ -110,7 +110,7 @@
(when edit
(send edit
run-after-edit-sequence
(lambda ()
(λ ()
(let ([admin (send edit get-admin)])
(send admin get-view #f #f width height)
(send s get-margin leftm topm rightm bottomm)
@ -121,7 +121,7 @@
;; edge is zero. Special case for efficiency in the
;; console printer
(let ([fallback
(lambda ()
(λ ()
(send edit get-snip-location
s left-edge-box top-edge-box))])
(cond

8
collects/framework/private/color-model.ss
View File

@ -127,8 +127,8 @@
(when (not (= width-a height-b))
(error 'matrix-multiply "matrix dimensions do not match for multiplication"))
(let ([b-t (transpose b)])
(map (lambda (row)
(map (lambda (col)
(map (λ (row)
(map (λ (col)
(inner-product row col))
b-t))
a))))
@ -201,8 +201,8 @@
;; (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b))))
(define rgb->xyz-matrix
(map (lambda (row)
(map (lambda (row-elt scalar) (* row-elt scalar 1/255)) row `(,sigma-r ,sigma-g ,sigma-b)))
(map (λ (row)
(map (λ (row-elt scalar) (* row-elt scalar 1/255)) row `(,sigma-r ,sigma-g ,sigma-b)))
pre-matrix))
(define xyz->rgb-matrix

108
collects/framework/private/color-prefs.ss
View File

@ -29,7 +29,7 @@
style-name
example-text
[update-style-delta
(lambda (func)
(λ (func)
(let ([delta (preferences:get pref-sym)])
(func delta)
(preferences:set pref-sym delta)))])
@ -53,7 +53,7 @@
hide-vscroll))))
(define (make-check name on off)
(let* ([c (lambda (check command)
(let* ([c (λ (check command)
(if (send check get-value)
(update-style-delta on)
(update-style-delta off)))]
@ -62,26 +62,26 @@
(define slant-check
(make-check (string-constant cs-italic)
(lambda (delta)
(λ (delta)
(send delta set-style-on 'slant)
(send delta set-style-off 'base))
(lambda (delta)
(λ (delta)
(send delta set-style-on 'base)
(send delta set-style-off 'slant))))
(define bold-check
(make-check (string-constant cs-bold)
(lambda (delta)
(λ (delta)
(send delta set-weight-on 'bold)
(send delta set-weight-off 'base))
(lambda (delta)
(λ (delta)
(send delta set-weight-on 'base)
(send delta set-weight-off 'bold))))
(define underline-check
(make-check (string-constant cs-underline)
(lambda (delta)
(λ (delta)
(send delta set-underlined-on #t)
(send delta set-underlined-off #f))
(lambda (delta)
(λ (delta)
(send delta set-underlined-off #t)
(send delta set-underlined-on #f))))
(define color-button
@ -89,7 +89,7 @@
(make-object button%
(string-constant cs-change-color)
hp
(lambda (color-button evt)
(λ (color-button evt)
(let* ([add (send (preferences:get pref-sym) get-foreground-add)]
[color (make-object color%
(send add get-r)
@ -102,7 +102,7 @@
color)])
(when users-choice
(update-style-delta
(lambda (delta)
(λ (delta)
(send delta set-delta-foreground users-choice)))))))))
(define style (send (send e get-style-list) find-named-style style-name))
@ -127,52 +127,52 @@
(map unbox (list b1 b2 b3))))
(define style-delta-get/set
(list (cons (lambda (x) (send x get-alignment-off))
(lambda (x v) (send x set-alignment-off v)))
(cons (lambda (x) (send x get-alignment-on))
(lambda (x v) (send x set-alignment-on v)))
(cons (lambda (x) (add/mult-get (send x get-background-add)))
(lambda (x v) (add/mult-set (send x get-background-add) v)))
(cons (lambda (x) (add/mult-get (send x get-background-mult)))
(lambda (x v) (add/mult-set (send x get-background-mult) v)))
(cons (lambda (x) (send x get-face))
(lambda (x v) (send x set-face v)))
(cons (lambda (x) (send x get-family))
(lambda (x v) (send x set-family v)))
(cons (lambda (x) (add/mult-get (send x get-foreground-add)))
(lambda (x v) (add/mult-set (send x get-foreground-add) v)))
(cons (lambda (x) (add/mult-get (send x get-foreground-mult)))
(lambda (x v) (add/mult-set (send x get-foreground-mult) v)))
(cons (lambda (x) (send x get-size-add))
(lambda (x v) (send x set-size-add v)))
(cons (lambda (x) (send x get-size-mult))
(lambda (x v) (send x set-size-mult v)))
(cons (lambda (x) (send x get-style-off))
(lambda (x v) (send x set-style-off v)))
(cons (lambda (x) (send x get-style-on))
(lambda (x v) (send x set-style-on v)))
(cons (lambda (x) (send x get-underlined-off))
(lambda (x v) (send x set-underlined-off v)))
(cons (lambda (x) (send x get-underlined-on))
(lambda (x v) (send x set-underlined-on v)))
(cons (lambda (x) (send x get-weight-off))
(lambda (x v) (send x set-weight-off v)))
(cons (lambda (x) (send x get-weight-on))
(lambda (x v) (send x set-weight-on v)))))
(list (cons (λ (x) (send x get-alignment-off))
(λ (x v) (send x set-alignment-off v)))
(cons (λ (x) (send x get-alignment-on))
(λ (x v) (send x set-alignment-on v)))
(cons (λ (x) (add/mult-get (send x get-background-add)))
(λ (x v) (add/mult-set (send x get-background-add) v)))
(cons (λ (x) (add/mult-get (send x get-background-mult)))
(λ (x v) (add/mult-set (send x get-background-mult) v)))
(cons (λ (x) (send x get-face))
(λ (x v) (send x set-face v)))
(cons (λ (x) (send x get-family))
(λ (x v) (send x set-family v)))
(cons (λ (x) (add/mult-get (send x get-foreground-add)))
(λ (x v) (add/mult-set (send x get-foreground-add) v)))
(cons (λ (x) (add/mult-get (send x get-foreground-mult)))
(λ (x v) (add/mult-set (send x get-foreground-mult) v)))
(cons (λ (x) (send x get-size-add))
(λ (x v) (send x set-size-add v)))
(cons (λ (x) (send x get-size-mult))
(λ (x v) (send x set-size-mult v)))
(cons (λ (x) (send x get-style-off))
(λ (x v) (send x set-style-off v)))
(cons (λ (x) (send x get-style-on))
(λ (x v) (send x set-style-on v)))
(cons (λ (x) (send x get-underlined-off))
(λ (x v) (send x set-underlined-off v)))
(cons (λ (x) (send x get-underlined-on))
(λ (x v) (send x set-underlined-on v)))
(cons (λ (x) (send x get-weight-off))
(λ (x v) (send x set-weight-off v)))
(cons (λ (x) (send x get-weight-on))
(λ (x v) (send x set-weight-on v)))))
(define (marshall-style style)
(map (lambda (fs) ((car fs) style)) style-delta-get/set))
(map (λ (fs) ((car fs) style)) style-delta-get/set))
(define (unmarshall-style info)
(let ([style (make-object style-delta%)])
(for-each (lambda (fs v) ((cdr fs) style v)) style-delta-get/set info)
(for-each (λ (fs v) ((cdr fs) style v)) style-delta-get/set info)
style))
(define (set-default sym code-style)
(preferences:set-default
sym
code-style
(lambda (x)
(λ (x)
(is-a? x style-delta%))))
(define (make-style-delta color bold? underline? italic?)
@ -200,7 +200,7 @@
(preferences:add-panel
(list (string-constant preferences-colors)
(string-constant background-color))
(lambda (parent)
(λ (parent)
(let ([vp (new vertical-panel% (parent parent))])
(add-solid-color-config (string-constant background-color)
vp
@ -237,7 +237,7 @@
(make-object button%
(string-constant cs-change-color)
hp
(lambda (color-button evt)
(λ (color-button evt)
(let ([users-choice
(get-color-from-user
(format sc-choose-color example-text)
@ -261,10 +261,10 @@
(new canvas%
(parent hp)
(paint-callback
(lambda (c dc)
(λ (c dc)
(draw (preferences:get pref-id)))))]
[draw
(lambda (clr)
(λ (clr)
(let ([dc (send canvas get-dc)])
(let-values ([(w h) (send canvas get-client-size)])
(send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
@ -275,7 +275,7 @@
(label (string-constant cs-change-color))
(parent hp)
(callback
(lambda (x y)
(λ (x y)
(let ([color (get-color-from-user
(string-constant choose-a-background-color)
(send hp get-top-level-window)
@ -284,14 +284,14 @@
(preferences:set pref-id color))))))])
(preferences:add-callback
pref-id
(lambda (p v) (draw v)))
(λ (p v) (draw v)))
panel))
;; add-to-preferences-panel : string (vertical-panel -> void) -> void
(define (add-to-preferences-panel panel-name func)
(preferences:add-panel
(list (string-constant preferences-colors) panel-name)
(lambda (parent)
(λ (parent)
(let ([panel (new vertical-panel% (parent parent))])
(func panel)
panel))))
@ -300,10 +300,10 @@
(define (register-color-pref pref-name style-name color)
(let ([sd (new style-delta%)])
(send sd set-delta-foreground color)
(preferences:set-default pref-name sd (lambda (x) (is-a? x style-delta%))))
(preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%))))
(preferences:set-un/marshall pref-name marshall-style unmarshall-style)
(preferences:add-callback pref-name
(lambda (sym v)
(λ (sym v)
(editor:set-standard-style-list-delta style-name v)))
(editor:set-standard-style-list-delta style-name (preferences:get pref-name))))))

22
collects/framework/private/color.ss
View File

@ -191,7 +191,7 @@
(color (send (get-style-list) find-named-style style-name))
(sp (+ in-start-pos (sub1 new-token-start)))
(ep (+ in-start-pos (sub1 new-token-end))))
(lambda ()
(λ ()
(change-style color sp ep #f)))
colors)))
; Using the non-spec version takes 3 times as long as the spec
@ -231,7 +231,7 @@
(+ start-pos orig-token-end change-length)))
(set! current-pos (+ start-pos orig-token-start))
(set! up-to-date? #f)
(queue-callback (lambda () (colorer-callback)) #f)))
(queue-callback (λ () (colorer-callback)) #f)))
((>= edit-start-pos invalid-tokens-start)
(let-values (((tok-start tok-end valid-tree invalid-tree)
(send invalid-tokens split (- edit-start-pos start-pos))))
@ -259,15 +259,15 @@
#;(printf "new coroutine~n")
(set! tok-cor
(coroutine
(lambda (enable-suspend)
(λ (enable-suspend)
(parameterize ((port-count-lines-enabled #t))
(re-tokenize (open-input-text-editor this current-pos end-pos
(lambda (x) #f))
(λ (x) #f))
current-pos
enable-suspend)))))
(set! rev (get-revision-number)))
(with-handlers ((exn:fail?
(lambda (exn)
(λ (exn)
(parameterize ((print-struct #t))
((error-display-handler)
(format "exception in colorer thread: ~s" exn)
@ -293,7 +293,7 @@
(unless (in-edit-sequence?)
(colorer-driver))
(unless up-to-date?
(queue-callback (lambda () (colorer-callback)) #f)))))
(queue-callback (λ () (colorer-callback)) #f)))))
;; Must not be called when the editor is locked
(define/private (finish-now)
@ -361,7 +361,7 @@
(begin-edit-sequence #f #f)
(finish-now)
(send tokens for-each
(lambda (start len type)
(λ (start len type)
(when (and should-color? (should-color-type? type))
(let ((color (send (get-style-list) find-named-style
(token-sym->style type)))
@ -409,7 +409,7 @@
(= caret-pos (+ start-pos start)))])
(set! clear-old-locations
(let ([old clear-old-locations])
(lambda ()
(λ ()
(old)
(off))))))
@ -619,7 +619,7 @@
(define/public (debug-printout)
(let* ((x null)
(f (lambda (a b c)
(f (λ (a b c)
(set! x (cons (list a b c) x)))))
(send tokens for-each f)
(printf "tokens: ~e~n" (reverse x))
@ -637,7 +637,7 @@
(super lock x)
(when (and restart-callback (not x))
(set! restart-callback #f)
(queue-callback (lambda () (colorer-callback)))))
(queue-callback (λ () (colorer-callback)))))
(define/override (on-focus on?)
@ -700,7 +700,7 @@
;; The arguments here are only used to be passed to start-colorer. Refer to its
;; documentation.
(init-field (get-token default-lexer)
(token-sym->style (lambda (x) "Standard"))
(token-sym->style (λ (x) "Standard"))
(matches null))
(define/override (on-disable-surrogate text)

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

@ -74,7 +74,7 @@
(make-object menu-item%
(string-constant convert-to-semicolon-comment)
menu
(lambda (x y)
(λ (x y)
(let ([to-ed (find-containing-editor)])
(when to-ed
(let ([this-pos (find-this-position)])

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

@ -67,7 +67,7 @@
internal-filename))
input-filename)])
(with-handlers ([exn:fail?
(lambda (exn)
(λ (exn)
(message-box
(string-constant error-saving)
(string-append
@ -96,7 +96,7 @@
internal-filename))
input-filename)])
(with-handlers ([exn:fail?
(lambda (exn)
(λ (exn)
(message-box
(string-constant error-loading)
(string-append
@ -190,14 +190,14 @@
(loop (send snip-admin get-editor)))]
[(send text get-canvas)
=>
(lambda (canvas)
(λ (canvas)
(send canvas get-top-level-window))]
[else #f]))))
[define edit-sequence-queue null]
[define edit-sequence-ht (make-hash-table)]
[define in-local-edit-sequence? #f]
[define/public local-edit-sequence? (lambda () in-local-edit-sequence?)]
[define/public local-edit-sequence? (λ () in-local-edit-sequence?)]
[define/public run-after-edit-sequence
(case-lambda
[(t) (run-after-edit-sequence t #f)]
@ -233,46 +233,44 @@
(t))
(void)])]
[define/public extend-edit-sequence-queue
(lambda (l ht)
(hash-table-for-each ht (lambda (k t)
(λ (l ht)
(hash-table-for-each ht (λ (k t)
(hash-table-put!
edit-sequence-ht
k t)))
(set! edit-sequence-queue (append l edit-sequence-queue)))]
[define/augment on-edit-sequence
(lambda ()
(set! in-local-edit-sequence? #t)
(inner (void) on-edit-sequence))]
[define/augment after-edit-sequence
(lambda ()
(set! in-local-edit-sequence? #f)
(let ([queue edit-sequence-queue]
[ht edit-sequence-ht]
[find-enclosing-editor
(lambda (editor)
(let ([admin (send editor get-admin)])
(cond
[(is-a? admin editor-snip-editor-admin<%>)
(send (send (send admin get-snip) get-admin) get-editor)]
[else #f])))])
(set! edit-sequence-queue null)
(set! edit-sequence-ht (make-hash-table))
(let loop ([editor (find-enclosing-editor this)])
(cond
[(and editor
(is-a? editor basic<%>)
(not (send editor local-edit-sequence?)))
(loop (find-enclosing-editor editor))]
[(and editor
(is-a? editor basic<%>))
(send editor extend-edit-sequence-queue queue ht)]
[else
(hash-table-for-each ht (lambda (k t) (t)))
(for-each (lambda (t) (t)) queue)])))
(inner (void) after-edit-sequence))]
(define/augment (on-edit-sequence)
(set! in-local-edit-sequence? #t)
(inner (void) on-edit-sequence))
(define/augment (after-edit-sequence)
(set! in-local-edit-sequence? #f)
(let ([queue edit-sequence-queue]
[ht edit-sequence-ht]
[find-enclosing-editor
(λ (editor)
(let ([admin (send editor get-admin)])
(cond
[(is-a? admin editor-snip-editor-admin<%>)
(send (send (send admin get-snip) get-admin) get-editor)]
[else #f])))])
(set! edit-sequence-queue null)
(set! edit-sequence-ht (make-hash-table))
(let loop ([editor (find-enclosing-editor this)])
(cond
[(and editor
(is-a? editor basic<%>)
(not (send editor local-edit-sequence?)))
(loop (find-enclosing-editor editor))]
[(and editor
(is-a? editor basic<%>))
(send editor extend-edit-sequence-queue queue ht)]
[else
(hash-table-for-each ht (λ (k t) (t)))
(for-each (λ (t) (t)) queue)])))
(inner (void) after-edit-sequence))
[define/override on-new-box
(lambda (type)
(λ (type)
(cond
[(eq? type 'text) (make-object editor-snip% (make-object text:basic%))]
[else (make-object editor-snip% (make-object pasteboard:basic%))]))]
@ -324,19 +322,19 @@
(define (set-font-size size)
(update-standard-style
(lambda (scheme-delta)
(λ (scheme-delta)
(send scheme-delta set-size-mult 0)
(send scheme-delta set-size-add size))))
(define (set-font-name name)
(update-standard-style
(lambda (scheme-delta)
(λ (scheme-delta)
(send scheme-delta set-delta-face name)
(send scheme-delta set-family 'modern))))
(define (set-font-smoothing sym)
(update-standard-style
(lambda (scheme-delta)
(λ (scheme-delta)
(send scheme-delta set-smoothing-on sym))))
(define (update-standard-style cng-delta)
@ -361,9 +359,9 @@
(set-font-size (preferences:get 'framework:standard-style-list:font-size))
(set-font-name (preferences:get 'framework:standard-style-list:font-name))
(set-font-smoothing (preferences:get 'framework:standard-style-list:smoothing))
(preferences:add-callback 'framework:standard-style-list:font-size (lambda (p v) (set-font-size v)))
(preferences:add-callback 'framework:standard-style-list:font-name (lambda (p v) (set-font-name v)))
(preferences:add-callback 'framework:standard-style-list:smoothing (lambda (p v) (set-font-smoothing v)))
(preferences:add-callback 'framework:standard-style-list:font-size (λ (p v) (set-font-size v)))
(preferences:add-callback 'framework:standard-style-list:font-name (λ (p v) (set-font-name v)))
(preferences:add-callback 'framework:standard-style-list:smoothing (λ (p v) (set-font-smoothing v)))
(unless (member (preferences:get 'framework:standard-style-list:font-name) (get-face-list 'mono))
(preferences:set 'framework:standard-style-list:font-name (get-family-builtin-face 'modern))))
@ -384,14 +382,14 @@
(define keymap-mixin
(mixin (basic<%>) (-keymap<%>)
[define/public get-keymaps
(lambda ()
(λ ()
(list (keymap:get-global)))]
(inherit set-keymap)
(super-instantiate ())
(let ([keymap (make-object keymap:aug-keymap%)])
(set-keymap keymap)
(for-each (lambda (k) (send keymap chain-to-keymap k #f))
(for-each (λ (k) (send keymap chain-to-keymap k #f))
(get-keymaps)))))
(define autowrap<%> (interface (basic<%>)))
@ -420,7 +418,7 @@
[name (if filename
(path->string (file-name-from-path (normalize-path filename)))
(get-filename/untitled-name))])
(for-each (lambda (canvas)
(for-each (λ (canvas)
(let ([tlw (send canvas get-top-level-window)])
(when (and (is-a? tlw frame:editor<%>)
(eq? this (send tlw get-editor)))
@ -501,7 +499,7 @@
(file-old? back-name))
(when (file-exists? back-name)
(delete-file back-name))
(with-handlers ([(lambda (x) #t) void])
(with-handlers ([(λ (x) #t) void])
(copy-file name back-name)))))
(inner (void) on-save-file name format))
(define/augment (on-close)
@ -536,7 +534,7 @@
(when (is-a? this text%)
(send this set-file-format 'standard))
(with-handlers ([exn:fail?
(lambda (exn)
(λ (exn)
(show-autosave-error exn orig-name)
(set! auto-save-error? #t)
(when (is-a? this text%)
@ -587,11 +585,11 @@
(super lock x)
(run-after-edit-sequence
(rec send-frame-update-lock-icon
(lambda ()
(λ ()
(unless callback-running?
(set! callback-running? #t)
(queue-callback
(lambda ()
(λ ()
(let ([frame (get-top-level-window)])
(when (is-a? frame frame:info<%>)
(send frame lock-status-changed)))

14
collects/framework/private/exit.ss
View File

@ -20,9 +20,9 @@
(define on-callbacks '())
(define insert-can?-callback
(lambda (cb)
(λ (cb)
(set! can?-callbacks (cons cb can?-callbacks))
(lambda ()
(λ ()
(set! can?-callbacks
(let loop ([cb-list can?-callbacks])
(cond
@ -31,9 +31,9 @@
[else (cons (car cb-list) (loop (cdr cb-list)))]))))))
(define insert-on-callback
(lambda (cb)
(λ (cb)
(set! on-callbacks (cons cb on-callbacks))
(lambda ()
(λ ()
(set! on-callbacks
(let loop ([cb-list on-callbacks])
(cond
@ -45,8 +45,8 @@
(define (set-exiting b) (set! is-exiting? b))
(define (exiting?) is-exiting?)
(define (can-exit?) (andmap (lambda (cb) (cb)) can?-callbacks))
(define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks))
(define (can-exit?) (andmap (λ (cb) (cb)) can?-callbacks))
(define (on-exit) (for-each (λ (cb) (cb)) on-callbacks))
(define (user-oks-exit)
(if (preferences:get 'framework:verify-exit)
@ -68,7 +68,7 @@
[(can-exit?)
(on-exit)
(queue-callback
(lambda ()
(λ ()
(exit)
(set! is-exiting? #f)))]
[else

80
collects/framework/private/finder.ss
View File

@ -25,7 +25,7 @@
(define dialog-parent-parameter (make-parameter #f))
(define filter-match?
(lambda (filter name msg)
(λ (filter name msg)
(let-values ([(base name dir?) (split-path name)])
(if (regexp-match-exact? filter (path->bytes name))
#t
@ -37,10 +37,10 @@
(define (get-last-directory) (preferences:get 'framework:last-directory))
(define make-relative
(lambda (s) s))
(λ (s) s))
(define build-updir
(lambda (dir)
(λ (dir)
(let-values ([(base _1 _2) (split-path dir)])
(or base dir))))
@ -70,10 +70,10 @@
(define current-dir #f)
(define/private set-listbox-directory ; sets directory in listbox
(lambda (dir) ; dir is normalized
(λ (dir) ; dir is normalized
(when (directory-exists? dir)
(gui-utils:show-busy-cursor
(lambda ()
(λ ()
(set! current-dir dir)
(set-last-directory dir)
(let-values
@ -126,7 +126,7 @@
(send name-list set-selection-and-edit 0))))))
(define/private set-edit
(lambda ()
(λ ()
(let* ([file (send name-list get-string-selection)])
(send directory-field set-value
(path->string
@ -135,20 +135,20 @@
current-dir))))))
[define/public do-period-in/exclusion
(lambda (check-box event)
(λ (check-box event)
(preferences:set
'framework:show-periods-in-dirlist
(send check-box get-value))
(set-listbox-directory current-dir))]
[define/public do-dir
(lambda (choice event)
(λ (choice event)
(let ([which (send choice get-selection)])
(if (< which (length dirs))
(set-listbox-directory (list-ref dirs which)))))]
[define/public do-name-list
(lambda (list-box evt)
(λ (list-box evt)
(if (eq? (send evt get-event-type) 'list-box-dclick)
(let ([dir (send directory-field get-value)])
(if (directory-exists? dir)
@ -160,10 +160,10 @@
(set-edit))))]
[define/public do-result-list
(lambda () #f)]
(λ () #f)]
[define/public do-ok
(lambda args
(λ args
(if multi-mode?
@ -245,8 +245,8 @@
'yes))
(let ([normal-path
(with-handlers
([(lambda (_) #t)
(lambda (_)
([(λ (_) #t)
(λ (_)
(message-box
(string-constant warning)
(format
@ -260,14 +260,14 @@
(show #f))))))))]))))]
[define/public add-one
(lambda (name)
(λ (name)
(unless (or (directory-exists? name)
(send result-list find-string name))
(send result-list append
(normal-case-path (normalize-path name)))))]
[define/public do-add
(lambda ()
(λ ()
(let ([name (send name-list get-string-selection)])
(if (string? name)
(let ([name (build-path current-dir
@ -275,7 +275,7 @@
(add-one name)))))]
[define/public do-add-all
(lambda ()
(λ ()
(let loop ([n 0])
(when (< n (send name-list get-number))
(let ([name (send name-list get-string n)])
@ -285,7 +285,7 @@
(loop (add1 n)))))))]
[define/public do-remove
(lambda ()
(λ ()
(let loop ([n 0])
(if (< n (send result-list get-number))
(if (send result-list is-selected? n)
@ -295,11 +295,11 @@
(loop (add1 n))))))]
[define/public do-cancel
(lambda ()
(λ ()
(set-box! result-box #f)
(show #f))]
(define/augment on-close (lambda () #f))
(define/augment on-close (λ () #f))
(super-new (label (if save-mode?
(string-constant put-file)
@ -316,7 +316,7 @@
(make-object message% prompt top-panel)
[define dir-choice (make-object choice% #f null top-panel
(lambda (choice event) (do-dir choice event)))]
(λ (choice event) (do-dir choice event)))]
[define middle-panel (make-object horizontal-panel% main-panel)]
[define left-middle-panel (make-object vertical-panel% middle-panel)]
@ -413,7 +413,7 @@
[else #f])))
[define/public set-selection-and-edit
(lambda (pos)
(λ (pos)
(when (> (get-number) 0)
(let* ([first-item (get-first-visible-item)]
[last-item (sub1 (+ (number-of-visible-items)
@ -423,7 +423,7 @@
(set-selection pos)))
(set-edit))]
[define/public on-default-action
(lambda ()
(λ ()
(when (> (get-number) 0)
(let* ([which (get-string-selection)]
[dir (build-path current-dir
@ -438,7 +438,7 @@
(super-new))]
[define name-list (make-object name-list%
#f null left-middle-panel (lambda (x y) (do-name-list x y))
#f null left-middle-panel (λ (x y) (do-name-list x y))
'(single))]
[define save-panel (when save-mode? (make-object horizontal-panel% main-panel))]
@ -452,11 +452,11 @@
[define directory-field
(keymap:call/text-keymap-initializer
(lambda ()
(λ ()
(make-object text-field%
(string-constant full-pathname)
directory-panel
(lambda (txt evt)
(λ (txt evt)
(when (eq? (send evt get-event-type) 'text-field-enter)
(let ([dir (send directory-field get-value)])
(if (directory-exists? dir)
@ -472,7 +472,7 @@
#f
null
right-middle-panel
(lambda (x y) (do-result-list))
(λ (x y) (do-result-list))
'(multiple)))]
[define add-panel
(when multi-mode?
@ -483,12 +483,12 @@
(make-object horizontal-panel% right-middle-panel))]
[define/private do-updir
(lambda ()
(λ ()
(set-listbox-directory (build-updir current-dir))
(set-focus-to-name-list))]
[define/private set-focus-to-name-list
(lambda ()
(λ ()
(send name-list focus))]
@ -497,7 +497,7 @@
(make-object check-box%
(string-constant show-dot-files)
dot-panel
(lambda (x y) (do-period-in/exclusion x y)))])
(λ (x y) (do-period-in/exclusion x y)))])
(send dot-panel stretchable-height #f)
(send dot-cb set-value
(preferences:get 'framework:show-periods-in-dirlist))))
@ -512,7 +512,7 @@
(make-object button%
(string-constant up-directory-button-label)
top-panel
(lambda (button evt) (do-updir)))
(λ (button evt) (do-updir)))
(send dir-choice stretchable-width #t)
(send name-list stretchable-width #t)
@ -527,13 +527,13 @@
(make-object button%
(string-constant add-button-label)
add-panel
(lambda (x y) (do-add))))]
(λ (x y) (do-add))))]
[define add-all-button (when multi-mode?
(begin0
(make-object button%
(string-constant add-all-button-label)
add-panel
(lambda (x y) (do-add-all)))
(λ (x y) (do-add-all)))
(make-object horizontal-panel% add-panel)))]
[define remove-button (when multi-mode?
(make-object horizontal-panel% remove-panel)
@ -541,17 +541,17 @@
(make-object button%
(string-constant remove-button-label)
remove-panel
(lambda (x y) (do-remove)))
(λ (x y) (do-remove)))
(make-object horizontal-panel% remove-panel)))]
(make-object vertical-panel% bottom-panel)
[define ok-button
(make-object button% (string-constant ok) bottom-panel
(lambda (x y) (do-ok))
(λ (x y) (do-ok))
(if multi-mode? '() '(border)))]
[define cancel-button (make-object button%
(string-constant cancel)
bottom-panel
(lambda (x y) (do-cancel)))]
(λ (x y) (do-cancel)))]
(make-object grow-box-spacer-pane% bottom-panel)
(cond
@ -561,7 +561,7 @@
(normalize-path start-dir)))]
[(get-last-directory)
=>
(lambda (dir)
(λ (dir)
(set-listbox-directory dir))]
[else (set-listbox-directory (current-directory))])
@ -574,8 +574,8 @@
; make-common takes a dialog-maker
; used to make one dialog object per session, now created each time
(define make-common
(lambda (make-dialog)
(lambda args
(λ (make-dialog)
(λ args
(let ([result-box (box #f)])
(apply make-dialog result-box args)
(unbox result-box)))))
@ -734,7 +734,7 @@
; external interfaces to file functions
(define -put-file
(lambda args
(λ args
(let ([actual-fun
(case (preferences:get 'framework:file-dialogs)
[(std) std-put-file]
@ -742,7 +742,7 @@
(apply actual-fun args))))
(define -get-file
(lambda args
(λ args
(let ([actual-fun
(case (preferences:get 'framework:file-dialogs)
[(std) std-get-file]

342
collects/framework/private/frame.ss
View File

@ -42,7 +42,7 @@
(define (reorder-menus frame)
(let* ([items (send (send frame get-menu-bar) get-items)]
[move-to-back
(lambda (name items)
(λ (name items)
(let loop ([items items]
[back null])
(cond
@ -53,7 +53,7 @@
(cons item back))
(cons item (loop (cdr items) back))))])))]
[move-to-front
(lambda (name items)
(λ (name items)
(reverse (move-to-back name (reverse items))))]
[re-ordered
(move-to-front
@ -65,12 +65,12 @@
(move-to-back
(string-constant windows-menu)
items))))])
(for-each (lambda (item) (send item delete)) items)
(for-each (lambda (item) (send item restore)) re-ordered)))
(for-each (λ (item) (send item delete)) items)
(for-each (λ (item) (send item restore)) re-ordered)))
(define (add-snip-menu-items edit-menu c%)
(let* ([get-edit-target-object
(lambda ()
(λ ()
(let ([menu-bar
(let loop ([p (send edit-menu get-parent)])
(cond
@ -83,19 +83,19 @@
(let ([frame (send menu-bar get-frame)])
(send frame get-edit-target-object)))))]
[edit-menu:do
(lambda (const)
(lambda (menu evt)
(λ (const)
(λ (menu evt)
(let ([edit (get-edit-target-object)])
(when (and edit
(is-a? edit editor<%>))
(send edit do-edit-operation const)))
#t))]
[on-demand
(lambda (menu-item)
(λ (menu-item)
(let ([edit (get-edit-target-object)])
(send menu-item enable (and edit (is-a? edit editor<%>)))))]
[insert-comment-box
(lambda ()
(λ ()
(let ([text (get-edit-target-object)])
(when text
(let ([snip (make-object comment-box:snip%)])
@ -104,7 +104,7 @@
(make-object c% (string-constant insert-comment-box-menu-item-label)
edit-menu
(lambda (x y) (insert-comment-box))
(λ (x y) (insert-comment-box))
#f #f
on-demand)
(make-object c% (string-constant insert-image-item)
@ -148,7 +148,7 @@
(define/override (on-exit)
(exit:on-exit)
(queue-callback
(lambda ()
(λ ()
(exit)
(exit:set-exiting #f))))
@ -167,28 +167,28 @@
(define after-init? #f)
(define/override on-drop-file
(lambda (filename)
(λ (filename)
(handler:edit-file filename)))
;; added call to set label here to hopefully work around a problem in mac mred
(inherit set-label change-children)
(define/override after-new-child
(lambda (child)
(λ (child)
(when after-init?
(change-children (lambda (l) (remq child l)))
(change-children (λ (l) (remq child l)))
(error 'frame:basic-mixin
"do not add children directly to a frame:basic (unless using make-root-area-container); use the get-area-container method instead"
))))
(define/public get-area-container% (lambda () vertical-panel%))
(define/public get-menu-bar% (lambda () menu-bar%))
(define/public get-area-container% (λ () vertical-panel%))
(define/public get-menu-bar% (λ () menu-bar%))
(define/public make-root-area-container
(lambda (% parent)
(λ (% parent)
(make-object % parent)))
(inherit can-close? on-close)
(define/public close
(lambda ()
(λ ()
(when (can-close?)
(on-close)
(show #f))))
@ -225,7 +225,7 @@
(define (setup-size-pref size-preferences-key w h)
(preferences:set-default size-preferences-key
(list w h)
(lambda (x)
(λ (x)
(and (pair? x)
(pair? (cdr x))
(null? (cddr x))
@ -276,7 +276,7 @@
(define/override (on-paint)
(let* ([dc (get-dc)]
[draw
(lambda (str bg-color bg-style line-color line-style)
(λ (str bg-color bg-style line-color line-style)
(send dc set-font (send (get-parent) get-label-font))
(let-values ([(w h) (get-client-size)]
[(tw th ta td) (send dc get-text-extent str)])
@ -333,7 +333,7 @@
r-root))
(define/public (open-status-line id)
(do-main-thread
(lambda ()
(λ ()
(when status-line-container-panel
(set! status-lines
(let loop ([status-lines status-lines])
@ -348,7 +348,7 @@
(define/public (close-status-line id)
(do-main-thread
(lambda ()
(λ ()
(when status-line-container-panel
;; decrement counter in for status line, or remove it if
@ -372,7 +372,7 @@
(when status-line-msg
(send (status-line-msg-message status-line-msg) set-label "")
(set-status-line-msg-id! status-line-msg #f)))
(let* ([msgs-that-can-be-removed (filter (lambda (x) (not (status-line-msg-id x))) status-line-msgs)]
(let* ([msgs-that-can-be-removed (filter (λ (x) (not (status-line-msg-id x))) status-line-msgs)]
[max-to-include (length status-lines)]
[msgs-to-remove
(let loop ([n max-to-include]
@ -383,8 +383,8 @@
[else (loop (- n 1) (cdr l))]))])
(send status-line-container-panel
change-children
(lambda (old-children)
(foldl (lambda (status-line-msg l)
(λ (old-children)
(foldl (λ (status-line-msg l)
(remq (status-line-msg-message status-line-msg) l))
old-children
msgs-to-remove)))
@ -399,20 +399,20 @@
;; update-status-line : symbol (union #f string)
(define/public (update-status-line id msg-txt)
(do-main-thread
(lambda ()
(λ ()
(unless (open-status-line? id)
(error 'update-status-line "unknown id ~e, other arg ~e" id msg-txt))
(if msg-txt
(cond
[(find-status-line-msg id)
=>
(lambda (existing-status-line-msg)
(λ (existing-status-line-msg)
(let ([msg (status-line-msg-message existing-status-line-msg)])
(unless (equal? (send msg get-label) msg-txt)
(send msg set-label msg-txt))))]
[(find-available-status-line-msg)
=>
(lambda (available-status-line-msg)
(λ (available-status-line-msg)
(send (status-line-msg-message available-status-line-msg) set-label msg-txt)
(set-status-line-msg-id! available-status-line-msg id))]
[else
@ -504,22 +504,22 @@
[define info-canvas #f]
(public get-info-canvas set-info-canvas get-info-editor)
[define get-info-canvas
(lambda ()
(λ ()
info-canvas)]
[define set-info-canvas
(lambda (c)
(λ (c)
(set! info-canvas c))]
[define get-info-editor
(lambda ()
(λ ()
(and info-canvas
(send info-canvas get-editor)))]
(public determine-width)
[define determine-width
(lambda (string canvas edit)
(λ (string canvas edit)
(send edit set-autowrap-bitmap #f)
(send canvas call-as-primary-owner
(lambda ()
(λ ()
(let ([lb (box 0)]
[rb (box 0)])
(send edit erase)
@ -551,14 +551,14 @@
(cond
[(or info-hidden? (not pref-value))
(send super-root change-children
(lambda (l)
(λ (l)
(if (memq outer-info-panel l)
(begin (unregister-collecting-blit gc-canvas)
(list rest-panel))
l)))]
[else
(send super-root change-children
(lambda (l)
(λ (l)
(if (memq outer-info-panel l)
l
(begin
@ -568,7 +568,7 @@
[define close-panel-callback
(preferences:add-callback
'framework:show-status-line
(lambda (p v)
(λ (p v)
(update-info-visibility v)))]
(define memory-cleanup void) ;; only for CVSers and nightly build users; used with memory-text
@ -598,7 +598,7 @@
(public update-info)
[define update-info
(lambda ()
(λ ()
(lock-status-changed))]
(super-new)
@ -609,11 +609,11 @@
(make-object grow-box-spacer-pane% outer-info-panel)
(public get-info-panel)
[define get-info-panel
(lambda ()
(λ ()
info-panel)]
(public update-memory-text)
[define update-memory-text
(lambda ()
(λ ()
(when show-memory-text?
(send memory-text begin-edit-sequence)
(send memory-text lock #f)
@ -642,14 +642,14 @@
(when show-memory-text?
(let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))]
[button (make-object button% (string-constant collect-button-label) panel
(lambda x
(λ x
(collect-garbage)
(update-memory-text)))]
[ec (make-object editor-canvas% panel memory-text '(no-hscroll no-vscroll))])
(determine-width "0,000,000,000" ec memory-text)
(update-memory-text)
(set! memory-cleanup
(lambda ()
(λ ()
(send ec set-editor #f)))
(send panel stretchable-width #f)))
@ -668,7 +668,7 @@
(unless (preferences:get 'framework:show-status-line)
(send super-root change-children
(lambda (l)
(λ (l)
(list rest-panel))))
(register-gc-blit)
@ -701,7 +701,7 @@
[define remove-first
(preferences:add-callback
'framework:col-offsets
(lambda (p v)
(λ (p v)
(editor-position-changed-offset/numbers
v
(preferences:get 'framework:display-line-numbers))
@ -709,23 +709,22 @@
[define remove-second
(preferences:add-callback
'framework:display-line-numbers
(lambda (p v)
(λ (p v)
(editor-position-changed-offset/numbers
(preferences:get 'framework:col-offsets)
v)
#t))]
[define/augment on-close
(lambda ()
(remove-first)
(remove-second)
(inner (void) on-close))]
(define/augment (on-close)
(remove-first)
(remove-second)
(inner (void) on-close))
[define last-start #f]
[define last-end #f]
[define last-params #f]
(define/private (editor-position-changed-offset/numbers offset? line-numbers?)
(let* ([edit (get-info-editor)]
[make-one
(lambda (pos)
(λ (pos)
(let* ([line (send edit position-paragraph pos)]
[col (find-col edit line pos)])
(if line-numbers?
@ -809,7 +808,7 @@
(define/public (anchor-status-changed)
(let ([info-edit (get-info-editor)]
[failed
(lambda ()
(λ ()
(unless (eq? anchor-last-state? #f)
(set! anchor-last-state? #f)
(send anchor-message show #f)))])
@ -831,10 +830,10 @@
(preferences:get 'framework:col-offsets)
(preferences:get 'framework:display-line-numbers)))
[define/public overwrite-status-changed
(lambda ()
(λ ()
(let ([info-edit (get-info-editor)]
[failed
(lambda ()
(λ ()
(set! overwrite-last-state? #f)
(send overwrite-message show #f))])
(cond
@ -851,15 +850,14 @@
(failed)])))]
[else
(failed)])))]
[define/override update-info
(lambda ()
(super update-info)
(update-macro-recording-icon)
(overwrite-status-changed)
(anchor-status-changed)
(editor-position-changed))]
(super-instantiate ())
(define/override (update-info)
(super update-info)
(update-macro-recording-icon)
(overwrite-status-changed)
(anchor-status-changed)
(editor-position-changed))
(super-new)
(inherit get-info-panel)
[define anchor-message
@ -884,10 +882,10 @@
(inherit determine-width)
(let ([move-front
(lambda (x l)
(λ (x l)
(cons x (remq x l)))])
(send (get-info-panel) change-children
(lambda (l)
(λ (l)
(move-front
macro-recording-message
(move-front
@ -952,7 +950,7 @@
(define/override (editing-this-file? filename)
(let ([path-equal?
(lambda (x y)
(λ (x y)
(equal? (normal-case-path (normalize-path x))
(normal-case-path (normalize-path y))))])
(let ([this-fn (get-filename)])
@ -975,7 +973,7 @@
(public get-entire-label get-label-prefix set-label-prefix)
[define get-entire-label
(lambda ()
(λ ()
(cond
[(string=? "" label)
label-prefix]
@ -983,25 +981,25 @@
label]
[else
(string-append label " - " label-prefix)]))]
[define get-label-prefix (lambda () label-prefix)]
[define get-label-prefix (λ () label-prefix)]
[define set-label-prefix
(lambda (s)
(λ (s)
(when (and (string? s)
(not (string=? s label-prefix)))
(set! label-prefix s)
(do-label)))]
[define/override get-label (lambda () label)]
[define/override get-label (λ () label)]
[define/override set-label
(lambda (t)
(λ (t)
(when (and (string? t)
(not (string=? t label)))
(set! label t)
(do-label)))]
(public get-canvas% get-canvas<%> make-canvas get-editor% get-editor<%> make-editor)
[define get-canvas% (lambda () editor-canvas%)]
[define get-canvas<%> (lambda () (class->interface editor-canvas%))]
[define make-canvas (lambda ()
[define get-canvas% (λ () editor-canvas%)]
[define get-canvas<%> (λ () (class->interface editor-canvas%))]
[define make-canvas (λ ()
(let ([% (get-canvas%)]
[<%> (get-canvas<%>)])
(unless (implementation? % <%>)
@ -1054,7 +1052,7 @@
(send item enable (not (send (get-editor) is-locked?))))
(define/override file-menu:revert-callback
(lambda (item control)
(λ (item control)
(let* ([edit (get-editor)]
[b (box #f)]
[filename (send edit get-filename b)])
@ -1093,28 +1091,28 @@
(send edit end-edit-sequence))
(send edit end-edit-sequence)))))))
(define/override file-menu:create-revert? (lambda () #t))
(define/override file-menu:create-revert? (λ () #t))
(define/override file-menu:save-callback
(lambda (item control)
(λ (item control)
(save)
#t))
(define/override file-menu:create-save? (lambda () #t))
(define/override file-menu:save-as-callback (lambda (item control) (save-as) #t))
(define/override file-menu:create-save-as? (lambda () #t))
(define/override file-menu:print-callback (lambda (item control)
(define/override file-menu:create-save? (λ () #t))
(define/override file-menu:save-as-callback (λ (item control) (save-as) #t))
(define/override file-menu:create-save-as? (λ () #t))
(define/override file-menu:print-callback (λ (item control)
(send (get-editor) print
#t
#t
(preferences:get 'framework:print-output-mode))
#t))
(define/override file-menu:create-print? (lambda () #t))
(define/override file-menu:create-print? (λ () #t))
(define/override edit-menu:between-select-all-and-find
(lambda (edit-menu)
(λ (edit-menu)
(let* ([c% (get-checkable-menu-item%)]
[on-demand
(lambda (menu-item)
(λ (menu-item)
(let ([edit (get-edit-target-object)])
(if (and edit (is-a? edit editor<%>))
(begin
@ -1124,7 +1122,7 @@
(send menu-item check #f)
(send menu-item enable #f)))))]
[callback
(lambda (item event)
(λ (item event)
(let ([edit (get-edit-target-object)])
(when (and edit
(is-a? edit editor<%>))
@ -1137,14 +1135,14 @@
(make-object separator-menu-item% edit-menu)))
(define/override help-menu:about-callback
(lambda (menu evt)
(λ (menu evt)
(message-box (application:current-app-name)
(format (string-constant welcome-to-something)
(application:current-app-name))
#f
'(ok app))))
(define/override help-menu:about-string (lambda () (application:current-app-name)))
(define/override help-menu:create-about? (lambda () #t))
(define/override help-menu:about-string (λ () (application:current-app-name)))
(define/override help-menu:create-about? (λ () #t))
(super-new (label (get-entire-label)))
@ -1152,13 +1150,13 @@
(define editor #f)
(public get-canvas get-editor)
(define get-canvas
(lambda ()
(λ ()
(unless canvas
(set! canvas (make-canvas))
(send canvas set-editor (get-editor)))
canvas))
(define get-editor
(lambda ()
(λ ()
(unless editor
(set! editor (make-editor))
(send (get-canvas) set-editor editor))
@ -1304,15 +1302,15 @@
(define text<%> (interface (-editor<%>)))
(define text-mixin
(mixin (-editor<%>) (text<%>)
[define/override get-editor<%> (lambda () (class->interface text%))]
[define/override get-editor% (lambda () text:keymap%)]
[define/override get-editor<%> (λ () (class->interface text%))]
[define/override get-editor% (λ () text:keymap%)]
(super-new)))
(define pasteboard<%> (interface (-editor<%>)))
(define pasteboard-mixin
(mixin (-editor<%>) (pasteboard<%>)
[define/override get-editor<%> (lambda () (class->interface pasteboard%))]
[define/override get-editor% (lambda () pasteboard:keymap%)]
[define/override get-editor<%> (λ () (class->interface pasteboard%))]
[define/override get-editor% (λ () pasteboard:keymap%)]
(super-new)))
(define delegate<%>
@ -1483,7 +1481,7 @@
[define rest-panel 'uninitialized-root]
[define super-root 'uninitialized-super-root]
[define/override make-root-area-container
(lambda (% parent)
(λ (% parent)
(let* ([s-root (super make-root-area-container
horizontal-panel%
parent)]
@ -1508,13 +1506,13 @@
(set! shown? #f)
(send (get-delegated-text) set-delegate #f)
(send super-root change-children
(lambda (l) (list rest-panel))))
(λ (l) (list rest-panel))))
(define/public (show-delegated-text)
(open-status-line 'plt:delegate)
(set! shown? #t)
(send (get-delegated-text) set-delegate delegatee)
(send super-root change-children
(lambda (l) (list rest-panel delegate-ec))))
(λ (l) (list rest-panel delegate-ec))))
(define/public (click-in-overview pos)
(when shown?
@ -1558,16 +1556,16 @@
(open-status-line 'plt:delegate)
(send (get-delegated-text) set-delegate delegatee)
(send super-root change-children
(lambda (l) (list rest-panel delegate-ec))))
(λ (l) (list rest-panel delegate-ec))))
(begin
(send (get-delegated-text) set-delegate #f)
(send super-root change-children (lambda (l) (list rest-panel)))))))
(send super-root change-children (λ (l) (list rest-panel)))))))
(define (search-dialog frame)
(init-find/replace-edits)
(keymap:call/text-keymap-initializer
(lambda ()
(λ ()
(let* ([to-be-searched-text (send frame get-text-to-search)]
[to-be-searched-canvas (send to-be-searched-text get-canvas)]
@ -1580,7 +1578,7 @@
frame)]
[copy-text
(lambda (from to)
(λ (from to)
(send to erase)
(let loop ([snip (send from find-first-snip)])
(when snip
@ -1615,60 +1613,60 @@
[button-panel (make-object horizontal-panel% dialog)]
[update-texts
(lambda ()
(λ ()
(send find-edit stop-searching)
(copy-text f-text find-edit)
(send find-edit start-searching)
(copy-text r-text replace-edit))]
[find-button (make-object button% (string-constant find) button-panel
(lambda x
(λ x
(update-texts)
(send frame search-again))
'(border))]
[replace-button (make-object button% (string-constant replace) button-panel
(lambda x
(λ x
(update-texts)
(send frame replace)))]
[replace-and-find-button (make-object button% (string-constant replace&find-again)
button-panel
(lambda x
(λ x
(update-texts)
(send frame replace&search)))]
[replace-to-end-button
(make-object button% (string-constant replace-to-end) button-panel
(lambda x
(λ x
(update-texts)
(send frame replace-all)))]
[dock-button (make-object button%
(string-constant dock)
button-panel
(lambda (btn evt)
(λ (btn evt)
(update-texts)
(preferences:set 'framework:search-using-dialog? #f)
(send frame unhide-search)))]
[close
(lambda ()
(λ ()
(when to-be-searched-canvas
(send to-be-searched-canvas force-display-focus #f))
(send dialog show #f))]
[close-button (make-object button% (string-constant close) button-panel
(lambda (x y)
(λ (x y)
(close)))]
[remove-pref-callback
(preferences:add-callback
'framework:search-using-dialog?
(lambda (p v)
(λ (p v)
(unless v
(close))))])
(unless allow-replace?
(send button-panel change-children
(lambda (l)
(λ (l)
(remq
replace-button
(remq
@ -1677,7 +1675,7 @@
replace-to-end-button
l)))))
(send dialog change-children
(lambda (l)
(λ (l)
(remq replace-panel l))))
(copy-text find-edit f-text)
@ -1726,12 +1724,12 @@
(define old-search-highlight void)
(define clear-search-highlight
(lambda ()
(λ ()
(begin (old-search-highlight)
(set! old-search-highlight void))))
(define reset-search-anchor
(let ([color (make-object color% "BLUE")])
(lambda (edit)
(λ (edit)
(old-search-highlight)
(let ([position
(if (eq? 'forward searching-direction)
@ -1768,7 +1766,7 @@
start end get-start
case-sensitive?)]
[pop-out
(lambda ()
(λ ()
(let ([admin (send edit get-admin)])
(if (is-a? admin editor-snip-editor-admin<%>)
(let* ([snip (send admin get-snip)]
@ -1790,7 +1788,7 @@
'after-or-none
'before-or-none))])
(let ([next-loop
(lambda ()
(λ ()
(if (eq? direction 'forward)
(loop (send current-snip next))
(loop (send current-snip previous))))])
@ -1850,14 +1848,14 @@
top-searching-edit))]
[not-found
(lambda (found-edit skip-beep?)
(λ (found-edit skip-beep?)
(send found-edit set-position search-anchor)
(when (and beep?
(not skip-beep?))
(bell))
#f)]
[found
(lambda (edit first-pos)
(λ (edit first-pos)
(let ([last-pos ((if (eq? searching-direction 'forward) + -)
first-pos (string-length string))])
(send* edit
@ -1944,7 +1942,7 @@
(unless find-edit
(set! find-edit (make-object find-text%))
(set! replace-edit (make-object replace-text%))
(for-each (lambda (keymap)
(for-each (λ (keymap)
(send keymap chain-to-keymap
(keymap:get-search)
#t))
@ -1955,16 +1953,16 @@
(mixin (standard-menus<%>) (searchable<%>)
(init-find/replace-edits)
(define super-root 'unitiaialized-super-root)
(define/override edit-menu:find-callback (lambda (menu evt) (move-to-search-or-search) #t))
(define/override edit-menu:create-find? (lambda () #t))
(define/override edit-menu:find-again-callback (lambda (menu evt) (search-again) #t))
(define/override edit-menu:create-find-again? (lambda () #t))
(define/override edit-menu:replace-and-find-again-callback (lambda (menu evt) (replace&search) #t))
(define/override edit-menu:find-callback (λ (menu evt) (move-to-search-or-search) #t))
(define/override edit-menu:create-find? (λ () #t))
(define/override edit-menu:find-again-callback (λ (menu evt) (search-again) #t))
(define/override edit-menu:create-find-again? (λ () #t))
(define/override edit-menu:replace-and-find-again-callback (λ (menu evt) (replace&search) #t))
(define/override edit-menu:replace-and-find-again-on-demand
(lambda (item) (send item enable (can-replace?))))
(define/override edit-menu:create-replace-and-find-again? (lambda () #t))
(λ (item) (send item enable (can-replace?))))
(define/override edit-menu:create-replace-and-find-again? (λ () #t))
(define/override make-root-area-container
(lambda (% parent)
(λ (% parent)
(let* ([s-root (super make-root-area-container
vertical-panel%
parent)]
@ -1972,13 +1970,12 @@
(set! super-root s-root)
root)))
(define/override on-activate
(lambda (on?)
(unless hidden?
(if on?
(reset-search-anchor (get-text-to-search))
(clear-search-highlight)))
(super on-activate on?)))
(define/override (on-activate on?)
(unless hidden?
(if on?
(reset-search-anchor (get-text-to-search))
(clear-search-highlight)))
(super on-activate on?))
(define/public (get-text-to-search)
(error 'get-text-to-search "abstract method in searchable-mixin"))
@ -1986,7 +1983,7 @@
(opt-lambda ([startup? #f])
(when search-gui-built?
(send super-root change-children
(lambda (l)
(λ (l)
(remove search-panel l))))
(clear-search-highlight)
(unless startup?
@ -2023,46 +2020,45 @@
(cond
[hide?
(send replace-canvas-panel change-children
(lambda (l) null))
(send replace-button-panel change-children (lambda (l) null))
(send middle-middle-panel change-children (lambda (l) null))]
(λ (l) null))
(send replace-button-panel change-children (λ (l) null))
(send middle-middle-panel change-children (λ (l) null))]
[else
(send replace-canvas-panel change-children
(lambda (l) (list replace-canvas)))
(λ (l) (list replace-canvas)))
(send replace-button-panel change-children
(lambda (l) (list replace-button)))
(λ (l) (list replace-button)))
(send middle-middle-panel change-children
(lambda (l) (list replace&search-button
(λ (l) (list replace&search-button
replace-all-button)))]))
(define remove-callback
(preferences:add-callback
'framework:search-using-dialog?
(lambda (p v)
(λ (p v)
(when p
(hide-search)))))
(define/augment on-close
(lambda ()
(remove-callback)
(let ([close-canvas
(lambda (canvas edit)
(send canvas set-editor #f))])
(when search-gui-built?
(close-canvas find-canvas find-edit)
(close-canvas replace-canvas replace-edit)))
(when (eq? this searching-frame)
(set-searching-frame #f))
(inner (void) on-close)))
(define/augment (on-close)
(remove-callback)
(let ([close-canvas
(λ (canvas edit)
(send canvas set-editor #f))])
(when search-gui-built?
(close-canvas find-canvas find-edit)
(close-canvas replace-canvas replace-edit)))
(when (eq? this searching-frame)
(set-searching-frame #f))
(inner (void) on-close))
(public set-search-direction can-replace? replace&search replace-all replace
toggle-search-focus move-to-search-or-search move-to-search-or-reverse-search
search-again)
(define set-search-direction
(lambda (x)
(λ (x)
(set-searching-direction x)
(when dir-radio
(send dir-radio set-selection (if (eq? x 'forward) 0 1)))))
(define can-replace?
(lambda ()
(λ ()
(let ([tx (get-text-to-search)])
(and
tx
@ -2073,7 +2069,7 @@
(send tx get-end-position))
(send find-edit get-text 0 (send find-edit last-position)))))))
(define replace&search
(lambda ()
(λ ()
(let ([text (get-text-to-search)])
(send text begin-edit-sequence)
(when (replace)
@ -2086,8 +2082,8 @@
(send embeded-replacee-edit get-start-position)
(send embeded-replacee-edit get-end-position))]
[done? (if (eq? 'forward searching-direction)
(lambda (x) (>= x (send replacee-edit last-position)))
(lambda (x) (<= x 0)))])
(λ (x) (>= x (send replacee-edit last-position)))
(λ (x) (<= x 0)))])
(send replacee-edit begin-edit-sequence)
(when (search-again)
(send embeded-replacee-edit set-position pos)
@ -2136,7 +2132,7 @@
find-canvas])
focus)))
(define move-to-search-or-search
(lambda ()
(λ ()
(set-searching-frame this)
(unhide-search)
(cond
@ -2148,7 +2144,7 @@
(search-again 'forward)
(send find-canvas focus))])))
(define move-to-search-or-reverse-search
(lambda ()
(λ ()
(set-searching-frame this)
(unhide-search)
(if (or (send find-canvas has-focus?)
@ -2200,7 +2196,7 @@
(define search-button (make-object button%
(string-constant find)
middle-left-panel
(lambda args (search-again))))
(λ args (search-again))))
(define _5
(set! replace-button-panel
@ -2212,26 +2208,26 @@
(define _6
(set! replace-button (make-object button% (string-constant replace)
replace-button-panel
(lambda x (replace)))))
(λ x (replace)))))
(define _7
(set! replace&search-button (make-object button%
(string-constant replace&find-again)
middle-middle-panel
(lambda x (replace&search)))))
(λ x (replace&search)))))
(define _8
(set! replace-all-button (make-object button%
(string-constant replace-to-end)
middle-middle-panel
(lambda x (replace-all)))))
(λ x (replace-all)))))
(define _9
(set! dir-radio (make-object radio-box%
#f
(list (string-constant forward)
(string-constant backward))
middle-right-panel
(lambda (dir-radio evt)
(λ (dir-radio evt)
(let ([forward (if (= (send dir-radio get-selection) 0)
'forward
'backward)])
@ -2241,23 +2237,23 @@
(define hide/undock-pane (make-object horizontal-panel% middle-right-panel))
(define hide-button (make-object button% (string-constant hide)
hide/undock-pane
(lambda args (hide-search))))
(λ args (hide-search))))
(define undock-button (make-object button% (string-constant undock)
hide/undock-pane
(lambda args (undock))))
(λ args (undock))))
(let ([align
(lambda (x y)
(λ (x y)
(let ([m (max (send x get-width)
(send y get-width))])
(send x min-width m)
(send y min-width m)))])
(align search-button replace-button)
(align replace&search-button replace-all-button))
(for-each (lambda (x) (send x set-alignment 'center 'center))
(for-each (λ (x) (send x set-alignment 'center 'center))
(list middle-left-panel middle-middle-panel))
(for-each (lambda (x) (send x stretchable-height #f))
(for-each (λ (x) (send x stretchable-height #f))
(list search-panel middle-left-panel middle-middle-panel middle-right-panel))
(for-each (lambda (x) (send x stretchable-width #f))
(for-each (λ (x) (send x stretchable-width #f))
(list middle-left-panel middle-middle-panel middle-right-panel))
(send find-canvas set-editor find-edit)
(send find-canvas stretchable-height #t)
@ -2284,10 +2280,10 @@
(send memory-text hide-caret #t)
(define show-memory-text?
(or (with-handlers ([exn:fail:filesystem?
(lambda (x) #f)])
(λ (x) #f)])
(directory-exists? (collection-path "cvs-time-stamp")))
(with-handlers ([exn:fail:filesystem?
(lambda (x) #f)])
(λ (x) #f)])
(directory-exists? (build-path (collection-path "framework") "CVS")))))
(define bday-click-canvas%

51
collects/framework/private/gen-standard-menus.ss
View File

@ -6,30 +6,29 @@
;; build-before-super-item-clause : an-item -> (listof clause)
(define build-before-super-item-clause
(lambda (item)
(λ (item)
(list
`[define/public ,(an-item->callback-name item) ,(an-item-proc item)]
`[define/public ,(an-item->get-item-name item)
(lambda () ,(an-item->item-name item))]
`[define/public ,(an-item->string-name item)
(lambda () ,(an-item-menu-string item))]
`[define/public ,(an-item->help-string-name item)
(lambda () ,(an-item-help-string item))]
`[define/public ,(an-item->on-demand-name item)
,(an-item-on-demand item)]
`[define/public ,(an-item->create-menu-item-name item)
(lambda () ,(an-item-create item))])))
`(define/public (,(an-item->get-item-name item))
,(an-item->item-name item))
`(define/public (,(an-item->string-name item))
,(an-item-menu-string item))
`(define/public (,(an-item->help-string-name item))
,(an-item-help-string item))
`(define/public ,(an-item->on-demand-name item) ,(an-item-on-demand item))
`(define/public (,(an-item->create-menu-item-name item))
,(an-item-create item)))))
;; build-before-super-clause : ((X -> sym) (X sexp) -> X -> (listof clause))
(define build-before-super-clause
(lambda (->name -procedure)
(lambda (obj)
(λ (->name -procedure)
(λ (obj)
(list `(define/public ,(->name obj)
,(case (-procedure obj)
[(nothing) '(lambda (menu) (void))]
[(separator) '(lambda (menu) (make-object separator-menu-item% menu))]
[(nothing) '(λ (menu) (void))]
[(separator) '(λ (menu) (make-object separator-menu-item% menu))]
[(nothing-with-standard-menus)
'(lambda (menu)
'(λ (menu)
(unless (current-eventspace-has-standard-menus?)
(make-object separator-menu-item% menu)))]
[else (error 'gen-standard-menus "unknown between sym: ~e" (-procedure obj))]))))))
@ -60,20 +59,20 @@
(label (,(an-item->string-name item)))
(parent ,(menu-item-menu-name item))
(help-string (,(an-item->help-string-name item)))
(demand-callback (lambda (menu-item) (,(an-item->on-demand-name item) menu-item))))
(demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))
`(instantiate (get-menu-item%) ()
(label (,(an-item->string-name item)))
(parent ,(menu-item-menu-name item))
(callback (let ([,callback-name (lambda (item evt) (,callback-name item evt))])
(callback (let ([,callback-name (λ (item evt) (,callback-name item evt))])
,callback-name))
(shortcut ,key)
(help-string (,(an-item->help-string-name item)))
(demand-callback (lambda (menu-item) (,(an-item->on-demand-name item) menu-item))))))))))
(demand-callback (λ (menu-item) (,(an-item->on-demand-name item) menu-item))))))))))
;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause))
(define build-after-super-clause
(lambda (->name)
(lambda (between/after)
(λ (->name)
(λ (between/after)
(list
`(,(->name between/after)
(,(menu-name->get-menu-name between/after)))))))
@ -117,12 +116,12 @@
(printf "writing to ~a~n" standard-menus.ss-filename)
(call-with-output-file standard-menus.ss-filename
(lambda (port)
(λ (port)
(pretty-print
`(define standard-menus<%>
(interface (basic<%>)
,@(apply append (map
(lambda (x)
(λ (x)
(cond
[(an-item? x)
(list
@ -152,7 +151,7 @@
(define remove-prefs-callback
(preferences:add-callback
'framework:menu-bindings
(lambda (p v)
(λ (p v)
(let loop ([menu (get-menu-bar)])
(when (is-a? menu menu:can-restore<%>)
(if v
@ -166,7 +165,7 @@
(for-each loop (send menu get-items)))))))
(inherit get-menu-bar show can-close? get-edit-target-object)
,@(apply append (map (lambda (x)
,@(apply append (map (λ (x)
(cond
[(between? x) (build-before-super-between-clause x)]
[(or (after? x) (before? x)) (build-before-super-before/after-clause x)]
@ -174,7 +173,7 @@
[(generic? x) (build-before-super-generic-clause x)]))
items))
(super-instantiate ())
,@(apply append (map (lambda (x)
,@(apply append (map (λ (x)
(cond
[(between? x) (build-after-super-between-clause x)]
[(an-item? x) (build-after-super-item-clause x)]

84
collects/framework/private/group.ss
View File

@ -41,7 +41,7 @@
(let ([menu-bar (send frame get-menu-bar)])
(and menu-bar
(let ([menus (send menu-bar get-items)])
(ormap (lambda (x)
(ormap (λ (x)
(if (string=? (string-constant windows-menu)
(send x get-plain-label))
x
@ -56,7 +56,7 @@
(when menu
;; to help the (conservative) gc.
(for-each (lambda (i) (send i delete)) (send menu get-items))
(for-each (λ (i) (send i delete)) (send menu get-items))
(set! windows-menus
(remove
@ -68,7 +68,7 @@
(let* ([windows (length windows-menus)]
[default-name (string-constant untitled)]
[get-name
(lambda (frame)
(λ (frame)
(let ([label (send frame get-label)])
(if (string=? label "")
(if (method-in-interface? 'get-entire-label (object-interface frame))
@ -80,26 +80,26 @@
label)))]
[sorted/visible-frames
(quicksort
(filter (lambda (x) (send (frame-frame x) is-shown?)) frames)
(lambda (f1 f2)
(filter (λ (x) (send (frame-frame x) is-shown?)) frames)
(λ (f1 f2)
(string-ci<=? (get-name (frame-frame f1))
(get-name (frame-frame f2)))))])
(for-each
(lambda (menu)
(for-each (lambda (item) (send item delete)) (send menu get-items))
(λ (menu)
(for-each (λ (item) (send item delete)) (send menu get-items))
(instantiate menu:can-restore-menu-item% ()
(label (string-constant bring-frame-to-front...))
(parent menu)
(callback (lambda (x y) (choose-a-frame (send (send menu get-parent) get-frame))))
(callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame))))
(shortcut #\j))
(instantiate menu:can-restore-menu-item% ()
(label (string-constant most-recent-window))
(parent menu)
(callback (lambda (x y) (most-recent-window-to-front)))
(callback (λ (x y) (most-recent-window-to-front)))
(shortcut #\'))
(make-object separator-menu-item% menu)
(for-each
(lambda (frame)
(λ (frame)
(let ([frame (frame-frame frame)])
(make-object menu-item%
(regexp-replace*
@ -107,7 +107,7 @@
(gui-utils:trim-string (get-name frame) 200)
"&&")
menu
(lambda (_1 _2)
(λ (_1 _2)
(send frame show #t)))))
sorted/visible-frames))
windows-menus)))
@ -121,14 +121,14 @@
(define/private (update-close-menu-item-state)
(let* ([set-close-menu-item-state!
(lambda (frame state)
(λ (frame state)
(when (is-a? frame frame:standard-menus<%>)
(let ([close-menu-item (send frame file-menu:get-close-menu)])
(when close-menu-item
(send close-menu-item enable state)))))])
(if (eq? (length frames) 1)
(set-close-menu-item-state! (car frames) #f)
(for-each (lambda (a-frame)
(for-each (λ (a-frame)
(set-close-menu-item-state! a-frame #t))
frames))))
@ -139,7 +139,7 @@
[open-here-frame open-here-frame]
[else
(let ([candidates
(filter (lambda (x) (is-a? (frame-frame x) frame:open-here<%>))
(filter (λ (x) (is-a? (frame-frame x) frame:open-here<%>))
frames)])
(if (null? candidates)
#f
@ -150,7 +150,7 @@
remove-frame clear on-close-all can-close-all? locate-file get-frames
frame-shown/hidden)
[define get-mdi-parent
(lambda ()
(λ ()
(when (and (eq? (system-type) 'windows)
(preferences:get 'framework:windows-mdi)
(not mdi-parent))
@ -163,36 +163,36 @@
(define (get-frames) (map frame-frame frames))
[define frame-label-changed
(lambda (frame)
(λ (frame)
(when (memq frame (map frame-frame frames))
(update-windows-menus)))]
[define frame-shown/hidden
(lambda (frame)
(λ (frame)
(when (memq frame (map frame-frame frames))
(update-windows-menus)))]
[define for-each-frame
(lambda (f)
(for-each (lambda (x) (f (frame-frame x))) frames)
(λ (f)
(for-each (λ (x) (f (frame-frame x))) frames)
(set! todo-to-new-frames
(let ([old todo-to-new-frames])
(lambda (frame) (old frame) (f frame)))))]
(λ (frame) (old frame) (f frame)))))]
[define get-active-frame
(lambda ()
(λ ()
(cond
[active-frame active-frame]
[(null? frames) #f]
[else (frame-frame (car frames))]))]
[define set-active-frame
(lambda (f)
(λ (f)
(when (and active-frame
(not (eq? active-frame f)))
(set! most-recent-window-box (make-weak-box active-frame)))
(set! active-frame f))]
[define insert-frame
(lambda (new-frame)
(unless (memf (lambda (fr) (eq? (frame-frame fr) new-frame))
(λ (new-frame)
(unless (memf (λ (fr) (eq? (frame-frame fr) new-frame))
frames)
(set! frame-counter (add1 frame-counter))
(let ([new-frames (cons (make-frame new-frame frame-counter)
@ -204,44 +204,44 @@
(todo-to-new-frames new-frame)))]
[define remove-frame
(lambda (f)
(λ (f)
(when (eq? f active-frame)
(set! active-frame #f))
(let ([new-frames
(remove
f frames
(lambda (f fr) (eq? f (frame-frame fr))))])
(λ (f fr) (eq? f (frame-frame fr))))])
(set! frames new-frames)
(update-close-menu-item-state)
(remove-windows-menu f)
(update-windows-menus)))]
[define clear
(lambda ()
(λ ()
(set! frames null)
#t)]
[define on-close-all
(lambda ()
(for-each (lambda (f)
(λ ()
(for-each (λ (f)
(let ([frame (frame-frame f)])
(send frame on-close)
(send frame show #f)))
frames))]
[define can-close-all?
(lambda ()
(andmap (lambda (f)
(λ ()
(andmap (λ (f)
(let ([frame (frame-frame f)])
(send frame can-close?)))
frames))]
[define locate-file
(lambda (name)
(λ (name)
(let* ([normalized
;; allow for the possiblity of filenames that are urls
(with-handlers ([(lambda (x) #t)
(lambda (x) name)])
(with-handlers ([(λ (x) #t)
(λ (x) name)])
(normal-case-path
(normalize-path name)))]
[test-frame
(lambda (frame)
(λ (frame)
(and (is-a? frame frame:basic<%>)
(send frame editing-this-file? normalized)))])
(let loop ([frames frames])
@ -259,12 +259,12 @@
(letrec-values ([(sorted-frames)
(quicksort
(send (get-the-frame-group) get-frames)
(lambda (x y) (string-ci<=? (send x get-label) (send y get-label))))]
(λ (x y) (string-ci<=? (send x get-label) (send y get-label))))]
[(d) (make-object dialog% (string-constant bring-frame-to-front) parent 400 600)]
[(lb) (instantiate list-box% ()
(label #f)
(choices (map (lambda (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames))
(callback (lambda (x y) (listbox-callback y)))
(choices (map (λ (x) (gui-utils:trim-string (send x get-label) 200)) sorted-frames))
(callback (λ (x y) (listbox-callback y)))
(parent d))]
[(t) (instantiate text:hide-caret/selection% ())]
[(ec) (instantiate canvas:basic% ()
@ -276,7 +276,7 @@
(alignment '(right center)))]
[(cancelled?) #t]
[(listbox-callback)
(lambda (evt)
(λ (evt)
(case (send evt get-event-type)
[(list-box)
@ -299,10 +299,10 @@
[(ok cancel)
(gui-utils:ok/cancel-buttons
bp
(lambda (x y)
(λ (x y)
(set! cancelled? #f)
(send d show #f))
(lambda (x y)
(λ (x y)
(send d show #f)))])
(send ec set-line-count 3)
(send ec set-editor t)
@ -321,7 +321,7 @@
(define (internal-get-the-frame-group)
(let ([the-frame-group (make-object %)])
(set! internal-get-the-frame-group (lambda () the-frame-group))
(set! internal-get-the-frame-group (λ () the-frame-group))
(internal-get-the-frame-group)))
(define (get-the-frame-group)

64
collects/framework/private/handler.ss
View File

@ -27,14 +27,14 @@
(define make-insert-handler
(letrec ([string-list?
(lambda (l)
(λ (l)
(cond
[(null? l) #t]
[(not (pair? l)) #f]
[else
(and (string? (car l))
(string-list? (cdr l)))]))])
(lambda (who name extension handler)
(λ (who name extension handler)
(cond
[(not (string? name))
(error who "name was not a string")]
@ -52,37 +52,37 @@
handler)]))))
(define insert-format-handler
(lambda args
(λ args
(set! format-handlers
(cons (apply make-insert-handler 'insert-format-handler args)
format-handlers))))
(define find-handler
(lambda (name handlers)
(λ (name handlers)
(let/ec exit
(let ([extension (if (string? name)
(or (filename-extension name)
"")
"")])
(for-each
(lambda (handler)
(λ (handler)
(let ([ext (handler-extension handler)])
(when (or (and (procedure? ext)
(ext name))
(and (pair? ext)
(ormap (lambda (ext) (string=? ext extension))
(ormap (λ (ext) (string=? ext extension))
ext)))
(exit (handler-handler handler)))))
handlers)
#f))))
(define find-format-handler
(lambda (name)
(λ (name)
(find-handler name format-handlers)))
; Finding format & mode handlers by name
(define find-named-handler
(lambda (name handlers)
(λ (name handlers)
(let loop ([l handlers])
(cond
[(null? l) #f]
@ -91,13 +91,13 @@
[else (loop (cdr l))]))))
(define find-named-format-handler
(lambda (name)
(λ (name)
(find-named-handler name format-handlers)))
; Open a file for editing
(define current-create-new-window
(make-parameter
(lambda (filename)
(λ (filename)
(let ([frame (make-object frame:text% filename)])
(send frame show #t)
frame))))
@ -106,11 +106,11 @@
(case-lambda
[(filename) (edit-file
filename
(lambda ()
(λ ()
((current-create-new-window) filename)))]
[(filename make-default)
(with-handlers ([(lambda (x) #f) ;exn:fail?
(lambda (exn)
(with-handlers ([(λ (x) #f) ;exn:fail?
(λ (exn)
(message-box
(string-constant error-loading)
(string-append
@ -123,7 +123,7 @@
(format "~s" exn))))
#f)])
(gui-utils:show-busy-cursor
(lambda ()
(λ ()
(if filename
(let ([already-open (send (group:get-the-frame-group)
locate-file
@ -136,7 +136,7 @@
[(and (preferences:get 'framework:open-here?)
(send (group:get-the-frame-group) get-open-here-frame))
=>
(lambda (fr)
(λ (fr)
(add-to-recent filename)
(send fr open-here filename)
(send fr show #t)
@ -157,7 +157,7 @@
;; add-to-recent : path -> void
(define (add-to-recent filename)
(let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
[old-ents (filter (lambda (x) (string=? (path->string (car x))
[old-ents (filter (λ (x) (string=? (path->string (car x))
(path->string filename)))
old-list)]
[old-ent (if (null? old-ents)
@ -203,7 +203,7 @@
;; with the positions `start' and `end'
(define (set-recent-position filename start end)
(let ([recent-items
(filter (lambda (x) (string=? (path->string (car x))
(filter (λ (x) (string=? (path->string (car x))
(path->string filename)))
(preferences:get 'framework:recently-opened-files/pos))])
(unless (null? recent-items)
@ -216,18 +216,18 @@
(let ([recently-opened-files
(preferences:get
'framework:recently-opened-files/pos)])
(for-each (lambda (item) (send item delete))
(for-each (λ (item) (send item delete))
(send menu get-items))
(instantiate menu-item% ()
(parent menu)
(label (string-constant show-recent-items-window-menu-item))
(callback (lambda (x y) (show-recent-items-window))))
(callback (λ (x y) (show-recent-items-window))))
(instantiate separator-menu-item% ()
(parent menu))
(for-each (lambda (recent-list-item)
(for-each (λ (recent-list-item)
(let ([filename (car recent-list-item)])
(instantiate menu-item% ()
(parent menu)
@ -237,7 +237,7 @@
(path->string filename)
"&&")
200))
(callback (lambda (x y) (open-recent-list-item recent-list-item))))))
(callback (λ (x y) (open-recent-list-item recent-list-item))))))
recently-opened-files)))
;; open-recent-list-item : recent-list-item -> void
@ -300,11 +300,11 @@
(define/private (refresh-hl recent-list-items)
(let ([ed (send hl get-editor)])
(send ed begin-edit-sequence)
(for-each (lambda (item) (send hl delete-item item)) (send hl get-items))
(for-each (lambda (item) (add-recent-item item))
(for-each (λ (item) (send hl delete-item item)) (send hl get-items))
(for-each (λ (item) (add-recent-item item))
(if (eq? (preferences:get 'framework:recently-opened-sort-by) 'name)
(quicksort recent-list-items
(lambda (x y) (string<=? (path->string (car x))
(λ (x y) (string<=? (path->string (car x))
(path->string (car y)))))
recent-list-items))
(send ed end-edit-sequence)))
@ -316,7 +316,7 @@
(field [remove-prefs-callback
(preferences:add-callback
'framework:recently-opened-files/pos
(lambda (p v)
(λ (p v)
(refresh-hl v)))])
(define/augment (on-close)
@ -333,12 +333,12 @@
(make-object button%
(string-constant recent-items-sort-by-name)
bp
(lambda (x y) (set-sort-by 'name)))]
(λ (x y) (set-sort-by 'name)))]
[sort-by-age-button
(make-object button%
(string-constant recent-items-sort-by-age)
bp
(lambda (x y) (set-sort-by 'age)))])
(λ (x y) (set-sort-by 'age)))])
(send bp stretchable-height #f)
(send sort-by-name-button stretchable-width #t)
@ -359,7 +359,7 @@
;; make-hierlist-item-mixin : recent-item -> mixin(arg to new-item method of hierlist)
(define (make-hierlist-item-mixin recent-item)
(lambda (%)
(λ (%)
(class %
(define/public (open-item)
(open-recent-list-item recent-item))
@ -368,18 +368,18 @@
(define *open-directory* ; object to remember last directory
(new (class object%
(field [the-dir #f])
[define/public get (lambda () the-dir)]
[define/public get (λ () the-dir)]
[define/public set-from-file!
(lambda (file)
(λ (file)
(set! the-dir (path-only file)))]
[define/public set-to-default
(lambda ()
(λ ()
(set! the-dir (current-directory)))]
(set-to-default)
(super-new))))
(define open-file
(lambda ()
(λ ()
(let ([file
(parameterize ([finder:dialog-parent-parameter
(and (preferences:get 'framework:open-here?)

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

@ -39,7 +39,7 @@
csr
(make-object cursor% fallback)))
(make-object cursor% fallback))))])
(lambda ()
(λ ()
(force ans))))]))
(define get-up/down-cursor (make-get-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s))

232
collects/framework/private/keymap.ss
View File

@ -28,7 +28,7 @@
(hash-table-get
user-keybindings-files
path
(lambda ()
(λ ()
(let ([sexp (and (file-exists? path)
(call-with-input-file path read))])
(match sexp
@ -42,7 +42,7 @@
(define (remove-user-keybindings-file path)
(let/ec k
(let ([km (hash-table-get user-keybindings-files path (lambda () (k (void))))])
(let ([km (hash-table-get user-keybindings-files path (λ () (k (void))))])
(send global remove-chained-keymap km)
(hash-table-remove! user-keybindings-files path))))
@ -69,9 +69,9 @@
(c-loop (cdr child-keymaps))]))])))))
(define (set-chained-keymaps parent-keymap children-keymaps)
(for-each (lambda (orig-sub) (send parent-keymap remove-chained-keymap))
(for-each (λ (orig-sub) (send parent-keymap remove-chained-keymap))
(send parent-keymap get-chained-keymaps))
(for-each (lambda (new-sub) (send parent-keymap chain-to-keymap new-sub #f))
(for-each (λ (new-sub) (send parent-keymap chain-to-keymap new-sub #f))
children-keymaps))
(define aug-keymap<%> (interface ((class->interface keymap%))
@ -107,11 +107,11 @@
(define/public (get-map-function-table/ht table)
(hash-table-for-each
function-table
(lambda (keyname fname)
(unless (hash-table-get table keyname (lambda () #f))
(λ (keyname fname)
(unless (hash-table-get table keyname (λ () #f))
(hash-table-put! table keyname fname))))
(for-each
(lambda (chained-keymap)
(λ (chained-keymap)
(when (is-a? chained-keymap aug-keymap<%>)
(send chained-keymap get-map-function-table/ht table)))
chained-keymaps)
@ -180,13 +180,13 @@
[command (if neg? #f 'd/c)]
[do-key
(lambda (char val)
(λ (char val)
(cond
[(eq? val #t) (string char)]
[(eq? val #f) (string #\~ char)]
[(eq? val 'd/c) #f]))])
(for-each (lambda (mod)
(for-each (λ (mod)
(let ([val (not (char=? (car mod) #\~))])
(case (if (char=? (car mod) #\~)
(cadr mod)
@ -200,7 +200,7 @@
(join-strings ":"
(filter
(lambda (x) x)
(λ (x) x)
(list
(do-key #\a alt)
(do-key #\c control)
@ -251,8 +251,8 @@
defaults)))
(define send-map-function-meta
(lambda (keymap key func)
(for-each (lambda (key) (send keymap map-function key func))
(λ (keymap key func)
(for-each (λ (key) (send keymap map-function key func))
(make-meta-prefix-list key))))
(define add-to-right-button-menu (make-parameter void))
@ -261,11 +261,11 @@
(define setup-global
; Define some useful keyboard functions
(let* ([ring-bell
(lambda (edit event)
(λ (edit event)
(bell))]
[mouse-popup-menu
(lambda (edit event)
(λ (edit event)
(when (send event button-down?)
(let ([a (send edit get-admin)])
(when a
@ -275,7 +275,7 @@
(append-editor-operation-menu-items m)
(for-each
(lambda (i)
(λ (i)
(when (is-a? i selectable-menu-item<%>)
(send i set-shortcut #f)))
(send m get-items))
@ -289,11 +289,11 @@
(send a popup-menu m (+ x 1) (+ y 1))))))))]
[toggle-anchor
(lambda (edit event)
(λ (edit event)
(send edit set-anchor
(not (send edit get-anchor))))]
[center-view-on-line
(lambda (edit event)
(λ (edit event)
(let ([new-mid-line (send edit position-line
(send edit get-start-position))]
[bt (box 0)]
@ -314,8 +314,8 @@
#t)]
[make-insert-brace-pair
(lambda (open-brace close-brace)
(lambda (edit event)
(λ (open-brace close-brace)
(λ (edit event)
(send edit begin-edit-sequence)
(let ([selection-start (send edit get-start-position)])
(send edit set-position (send edit get-end-position))
@ -325,7 +325,7 @@
(send edit end-edit-sequence)))]
[insert-lambda-template
(lambda (edit event)
(λ (edit event)
(send edit begin-edit-sequence)
(let ([selection-start (send edit get-start-position)])
(send edit set-position (send edit get-end-position))
@ -333,18 +333,18 @@
(send edit set-position selection-start)
(send edit insert ") ")
(send edit set-position selection-start)
(send edit insert "(lambda ("))
(send edit insert "(λ ("))
(send edit end-edit-sequence))]
[collapse-variable-space
;; As per emacs: collapse tabs & spaces around the point,
;; perhaps leaving a single space.
;; drscheme bonus: if at end-of-line, collapse into the next line.
(lambda (leave-one? edit event)
(λ (leave-one? edit event)
(letrec ([last-pos (send edit last-position)]
[sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)]
[collapsible? (lambda (c) (and (char-whitespace? c)
[collapsible? (λ (c) (and (char-whitespace? c)
(not (char=? #\newline c))))]
[find-noncollapsible
; Return index of next non-collapsible char,
@ -352,7 +352,7 @@
; NB returns -1 or last-pos, if examining
; initial/final whitespace
; (or, when initial pos is outside of [0,last-pos).)
(lambda (pos dir)
(λ (pos dir)
(let loop ([pos pos])
(cond [(< pos 0) -1]
[(>= pos last-pos) last-pos]
@ -389,17 +389,17 @@
(send edit end-edit-sequence))))))]
[collapse-space
(lambda (edit event)
(λ (edit event)
(collapse-variable-space #t edit event))]
[remove-space
(lambda (edit event)
(λ (edit event)
(collapse-variable-space #f edit event))]
[collapse-newline
(lambda (edit event)
(λ (edit event)
(letrec ([find-nonwhite
(lambda (pos d offset)
(λ (pos d offset)
(let/ec escape
(let ([max (if (> offset 0)
(send edit last-position)
@ -459,7 +459,7 @@
end-line-start)]))))))]
[open-line
(lambda (edit event)
(λ (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(if (= sel-start sel-end)
@ -468,7 +468,7 @@
(set-position sel-start)))))]
[transpose-chars
(lambda (edit event)
(λ (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(when (and (= sel-start sel-end)
@ -490,7 +490,7 @@
(end-edit-sequence)))))))]
[transpose-words
(lambda (edit event)
(λ (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(when (= sel-start sel-end)
@ -520,7 +520,7 @@
(end-edit-sequence))))))))))]
[capitalize-it
(lambda (edit char-case1 char-case2)
(λ (edit char-case1 char-case2)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)]
[real-end (send edit last-position)])
@ -547,17 +547,17 @@
(set-position word-end))))))]
[capitalize-word
(lambda (edit event)
(λ (edit event)
(capitalize-it edit char-upcase char-downcase))]
[upcase-word
(lambda (edit event)
(λ (edit event)
(capitalize-it edit char-upcase char-upcase))]
[downcase-word
(lambda (edit event)
(λ (edit event)
(capitalize-it edit char-downcase char-downcase))]
[kill-word
(lambda (edit event)
(λ (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(let ([end-box (box sel-end)])
@ -565,7 +565,7 @@
(send edit kill 0 sel-start (unbox end-box)))))]
[backward-kill-word
(lambda (edit event)
(λ (edit event)
(let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)])
(let ([start-box (box sel-start)])
@ -573,7 +573,7 @@
(send edit kill 0 (unbox start-box) sel-end))))]
[region-click
(lambda (edit event f)
(λ (edit event f)
(when (and (send event button-down?)
(is-a? edit text%))
(let ([x-box (box (send event get-x))]
@ -591,39 +591,39 @@
(f click-pos eol start-pos click-pos)
(f click-pos eol click-pos end-pos)))))))]
[copy-click-region
(lambda (edit event)
(λ (edit event)
(region-click edit event
(lambda (click eol start end)
(λ (click eol start end)
(send edit flash-on start end)
(send edit copy #f 0 start end))))]
[cut-click-region
(lambda (edit event)
(λ (edit event)
(region-click edit event
(lambda (click eol start end)
(λ (click eol start end)
(send edit cut #f 0 start end))))]
[paste-click-region
(lambda (edit event)
(λ (edit event)
(region-click edit event
(lambda (click eol start end)
(λ (click eol start end)
(send edit set-position click)
(send edit paste-x-selection 0 click))))]
[mouse-copy-clipboard
(lambda (edit event)
(λ (edit event)
(send edit copy #f (send event get-time-stamp)))]
[mouse-paste-clipboard
(lambda (edit event)
(λ (edit event)
(send edit paste (send event get-time-stamp)))]
[mouse-cut-clipboard
(lambda (edit event)
(λ (edit event)
(send edit cut #f (send event get-time-stamp)))]
[select-click-word
(lambda (edit event)
(λ (edit event)
(region-click edit event
(lambda (click eol start end)
(λ (click eol start end)
(let ([start-box (box click)]
[end-box (box click)])
(send edit find-wordbreak
@ -634,9 +634,9 @@
(unbox start-box)
(unbox end-box))))))]
[select-click-line
(lambda (edit event)
(λ (edit event)
(region-click edit event
(lambda (click eol start end)
(λ (click eol start end)
(let* ([line (send edit position-line
click eol)]
[start (send edit line-start-position
@ -646,10 +646,10 @@
(send edit set-position start end)))))]
[goto-line
(lambda (edit event)
(λ (edit event)
(let ([num-str
(call/text-keymap-initializer
(lambda ()
(λ ()
(get-text-from-user
(string-constant goto-line)
(string-constant goto-line))))])
@ -672,10 +672,10 @@
#t)]
[goto-position
(lambda (edit event)
(λ (edit event)
(let ([num-str
(call/text-keymap-initializer
(lambda ()
(λ ()
(get-text-from-user
(string-constant goto-position)
(string-constant goto-position))))])
@ -685,26 +685,26 @@
(send edit set-position (sub1 pos))))))
#t)]
[repeater
(lambda (n edit)
(λ (n edit)
(let* ([km (send edit get-keymap)]
[done
(lambda ()
(λ ()
(send km set-break-sequence-callback void)
(send km remove-grab-key-function))])
(send km set-grab-key-function
(lambda (name local-km edit event)
(λ (name local-km edit event)
(if name
(begin
(done)
(dynamic-wind
(lambda ()
(λ ()
(send edit begin-edit-sequence))
(lambda ()
(λ ()
(let loop ([n n])
(unless (zero? n)
(send local-km call-function name edit event)
(loop (sub1 n)))))
(lambda ()
(λ ()
(send edit end-edit-sequence))))
(let ([k (send event get-key-code)])
(if (and (char? k) (char<=? #\0 k #\9))
@ -713,26 +713,26 @@
(begin
(done)
(dynamic-wind
(lambda ()
(λ ()
(send edit begin-edit-sequence))
(lambda ()
(λ ()
(let loop ([n n])
(unless (zero? n)
(send edit on-char event)
(loop (sub1 n)))))
(lambda ()
(λ ()
(send edit end-edit-sequence)))))))
#t))
(send km set-break-sequence-callback done)
#t))]
[make-make-repeater
(lambda (n)
(lambda (edit event)
(λ (n)
(λ (edit event)
(repeater n edit)))]
[current-macro '()]
[building-macro #f] [build-macro-km #f] [build-protect? #f]
[show/hide-keyboard-macro-icon
(lambda (edit on?)
(λ (edit on?)
(when (is-a? edit editor:basic<%>)
(let ([frame (send edit get-top-level-window)])
(when (is-a? frame frame:text-info<%>)
@ -740,7 +740,7 @@
(send frame update-shown)))))]
[do-macro
(lambda (edit event)
(λ (edit event)
; If c:x;e during record, copy the old macro
(when building-macro
(set! building-macro (append (reverse current-macro)
@ -748,13 +748,13 @@
(let ([bm building-macro]
[km (send edit get-keymap)])
(dynamic-wind
(lambda ()
(λ ()
(set! building-macro #f)
(send edit begin-edit-sequence))
(lambda ()
(λ ()
(let/ec escape
(for-each
(lambda (f)
(λ (f)
(let ([name (car f)]
[event (cdr f)])
(if name
@ -762,17 +762,17 @@
(escape #t))
(send edit on-char event))))
current-macro)))
(lambda ()
(λ ()
(send edit end-edit-sequence)
(set! building-macro bm))))
#t)]
[start-macro
(lambda (edit event)
(λ (edit event)
(if building-macro
(send build-macro-km break-sequence)
(letrec ([km (send edit get-keymap)]
[done
(lambda ()
(λ ()
(if build-protect?
(send km set-break-sequence-callback done)
(begin
@ -784,15 +784,15 @@
(show/hide-keyboard-macro-icon edit #t)
(set! build-macro-km km)
(send km set-grab-key-function
(lambda (name local-km edit event)
(λ (name local-km edit event)
(dynamic-wind
(lambda ()
(λ ()
(set! build-protect? #t))
(lambda ()
(λ ()
(if name
(send local-km call-function name edit event)
(send edit on-default-char event)))
(lambda ()
(λ ()
(set! build-protect? #f)))
(when building-macro
(set! building-macro
@ -802,14 +802,14 @@
(send km set-break-sequence-callback done)))
#t)]
[end-macro
(lambda (edit event)
(λ (edit event)
(when building-macro
(set! current-macro (reverse building-macro))
(set! build-protect? #f)
(send build-macro-km break-sequence))
#t)]
[delete-key
(lambda (edit event)
(λ (edit event)
(let ([kmap (send edit get-keymap)])
(send kmap call-function
(if (preferences:get 'framework:delete-forward?)
@ -818,12 +818,12 @@
edit event #t)))]
[toggle-overwrite
(lambda (edit event)
(λ (edit event)
(send edit set-overwrite-mode
(not (send edit get-overwrite-mode))))]
[down-into-embedded-editor
(lambda (text event)
(λ (text event)
(let ([start (send text get-start-position)]
[end (send text get-end-position)])
(when (= start end)
@ -850,7 +850,7 @@
#t)]
[forward-to-next-embedded-editor
(lambda (text event)
(λ (text event)
(let ([start-pos (send text get-start-position)]
[end-pos (send text get-end-position)])
(when (= start-pos end-pos)
@ -863,7 +863,7 @@
#t)]
[back-to-prev-embedded-editor
(lambda (text event)
(λ (text event)
(let ([start-pos (send text get-start-position)]
[end-pos (send text get-end-position)])
(when (= start-pos end-pos)
@ -876,7 +876,7 @@
#t)]
[up-out-of-embedded-editor
(lambda (text event)
(λ (text event)
(let ([start (send text get-start-position)]
[end (send text get-end-position)])
(when (= start end)
@ -893,18 +893,18 @@
#t)]
[make-read-only
(lambda (text event)
(λ (text event)
(send text lock #t)
#t)])
(lambda (kmap)
(let* ([map (lambda (key func)
(λ (kmap)
(let* ([map (λ (key func)
(send kmap map-function key func))]
[map-meta (lambda (key func)
[map-meta (λ (key func)
(send-map-function-meta kmap key func))]
[add (lambda (name func)
[add (λ (name func)
(send kmap add-function name func))]
[add-m (lambda (name func)
[add-m (λ (name func)
(send kmap add-function name func))])
; Map names to keyboard functions
@ -916,7 +916,7 @@
(add "toggle-overwrite" toggle-overwrite)
(add "exit" (lambda (edit event)
(add "exit" (λ (edit event)
(let ([frame (send edit get-frame)])
(if (and frame
(is-a? frame frame:standard-menus<%>))
@ -1156,8 +1156,8 @@
(define setup-search
(let* ([send-frame
(lambda (invoke-method)
(lambda (edit event)
(λ (invoke-method)
(λ (edit event)
(let ([frame
(cond
[(is-a? edit editor<%>)
@ -1171,26 +1171,26 @@
(invoke-method frame)
(bell)))
#t))])
(lambda (kmap)
(let* ([map (lambda (key func)
(λ (kmap)
(let* ([map (λ (key func)
(send kmap map-function key func))]
[map-meta (lambda (key func)
[map-meta (λ (key func)
(send-map-function-meta kmap key func))]
[add (lambda (name func)
[add (λ (name func)
(send kmap add-function name func))]
[add-m (lambda (name func)
[add-m (λ (name func)
(send kmap add-function name func))])
(add "move-to-search-or-search"
(send-frame (lambda (f) (send f move-to-search-or-search)))) ;; key 1
(send-frame (λ (f) (send f move-to-search-or-search)))) ;; key 1
(add "move-to-search-or-reverse-search"
(send-frame (lambda (f) (send f move-to-search-or-reverse-search)))) ;; key 1b, backwards
(send-frame (λ (f) (send f move-to-search-or-reverse-search)))) ;; key 1b, backwards
(add "find-string-again"
(send-frame (lambda (f) (send f search-again)))) ;; key 2
(send-frame (λ (f) (send f search-again)))) ;; key 2
(add "toggle-search-focus"
(send-frame (lambda (f) (send f toggle-search-focus)))) ;; key 3
(send-frame (λ (f) (send f toggle-search-focus)))) ;; key 3
(add "hide-search"
(send-frame (lambda (f) (send f hide-search)))) ;; key 4
(send-frame (λ (f) (send f hide-search)))) ;; key 4
(case (system-type)
[(unix)
@ -1223,7 +1223,7 @@
(define setup-file
(let* ([get-outer-editor ;; : text% -> text%
;; returns the outermost editor, if this editor is nested in an editor snip.
(lambda (edit)
(λ (edit)
(let loop ([edit edit])
(let ([admin (send edit get-admin)])
(cond
@ -1231,7 +1231,7 @@
(loop (send (send (send admin get-snip) get-admin) get-editor))]
[else edit]))))]
[save-file-as
(lambda (this-edit event)
(λ (this-edit event)
(let ([edit (get-outer-editor this-edit)])
(parameterize ([finder:dialog-parent-parameter
(and (is-a? edit editor:basic<%>)
@ -1241,24 +1241,24 @@
(send edit save-file/gui-error file)))))
#t)]
[save-file
(lambda (this-edit event)
(λ (this-edit event)
(let ([edit (get-outer-editor this-edit)])
(if (send edit get-filename)
(send edit save-file/gui-error)
(save-file-as edit event)))
#t)]
[load-file
(lambda (edit event)
(λ (edit event)
(handler:open-file)
#t)])
(lambda (kmap)
(let* ([map (lambda (key func)
(λ (kmap)
(let* ([map (λ (key func)
(send kmap map-function key func))]
[map-meta (lambda (key func)
[map-meta (λ (key func)
(send-map-function-meta kmap key func))]
[add (lambda (name func)
[add (λ (name func)
(send kmap add-function name func))]
[add-m (lambda (name func)
[add-m (λ (name func)
(send kmap add-function name func))])
(add "save-file" save-file)
@ -1272,10 +1272,10 @@
(define (setup-editor kmap)
(let ([add/map
(lambda (func op key)
(λ (func op key)
(send kmap add-function
func
(lambda (editor evt)
(λ (editor evt)
(send editor do-edit-operation op)))
(send kmap map-function
(string-append
@ -1322,7 +1322,7 @@
(define (call/text-keymap-initializer thunk)
(let ([ctki (current-text-keymap-initializer)])
(parameterize ([current-text-keymap-initializer
(lambda (keymap)
(λ (keymap)
(send keymap chain-to-keymap global #t)
(ctki keymap))])
(thunk)))))))

86
collects/framework/private/main.ss
View File

@ -20,25 +20,25 @@
[color-prefs : framework:color-prefs^]
[scheme : framework:scheme^])
(application-preferences-handler (lambda () (preferences:show-dialog)))
(application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:set-default 'framework:basic-canvas-background
(send the-color-database find-color "white")
(lambda (x) (is-a? x color%)))
(λ (x) (is-a? x color%)))
(preferences:set-un/marshall
'framework:basic-canvas-background
(lambda (clr) (list (send clr red) (send clr green) (send clr blue)))
(lambda (lst) (and (pair? lst)
(λ (clr) (list (send clr red) (send clr green) (send clr blue)))
(λ (lst) (and (pair? lst)
(pair? (cdr lst))
(pair? (cddr lst))
(null? (cdddr lst))
(make-object color% (car lst) (cadr lst) (caddr lst)))))
(preferences:set-default 'framework:special-option-key #f boolean?)
(preferences:add-callback 'framework:special-option-key (lambda (p v) (special-option-key v)))
(preferences:add-callback 'framework:special-option-key (λ (p v) (special-option-key v)))
(special-option-key (preferences:get 'framework:special-option-key))
(preferences:set-default 'framework:fraction-snip-style 'mixed (lambda (x) (memq x '(mixed improper))))
(preferences:set-default 'framework:fraction-snip-style 'mixed (λ (x) (memq x '(mixed improper))))
(preferences:set-default 'framework:standard-style-list:font-name
(get-family-builtin-face 'modern)
@ -50,12 +50,12 @@
[stl (send txt get-style-list)]
[bcs (send stl basic-style)])
(send bcs get-size))
(lambda (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
(λ (x) (and (number? x) (exact? x) (integer? x) (positive? x))))
(preferences:set-default
'framework:standard-style-list:smoothing
'default
(lambda (x)
(λ (x)
(memq x '(unsmoothed partly-smoothed smoothed default))))
(editor:set-standard-style-list-pref-callbacks)
@ -67,18 +67,18 @@
(* 3/4 256)
(- (* 7/8 256) 1))])
(make-object color% gray-level gray-level gray-level))
(lambda (x) (is-a? x color%)))
(λ (x) (is-a? x color%)))
(preferences:set-un/marshall
'framework:paren-match-color
(lambda (c) (list (send c red) (send c green) (send c blue)))
(lambda (l) (make-object color% (car l) (cadr l) (caddr l))))
(λ (c) (list (send c red) (send c green) (send c blue)))
(λ (l) (make-object color% (car l) (cadr l) (caddr l))))
(preferences:set-default 'framework:recently-opened-files/pos
null
(lambda (x) (and (list? x)
(λ (x) (and (list? x)
(andmap
(lambda (x)
(λ (x)
(and (list? x)
(= 3 (length x))
(path? (car x))
@ -88,12 +88,12 @@
(preferences:set-un/marshall
'framework:recently-opened-files/pos
(lambda (l) (map (lambda (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
(lambda (l)
(λ (l) (map (λ (ele) (cons (path->bytes (car ele)) (cdr ele))) l))
(λ (l)
(let/ec k
(unless (list? l)
(k '()))
(map (lambda (x)
(map (λ (x)
(unless (and (list? x)
(= 3 (length x))
(bytes? (car x))
@ -105,27 +105,27 @@
(preferences:set-default 'framework:last-directory
(find-system-path 'doc-dir)
(lambda (x) (or (not x) path-string?)))
(λ (x) (or (not x) path-string?)))
(preferences:set-un/marshall 'framework:last-directory
(lambda (x) (and (path? x) (path->bytes x)))
(lambda (x)
(λ (x) (and (path? x) (path->bytes x)))
(λ (x)
(and (bytes? x)
(bytes->path x))))
(preferences:set-default 'framework:recent-max-count
50
(lambda (x) (and (number? x)
(λ (x) (and (number? x)
(x . > . 0)
(integer? x))))
(preferences:add-callback
'framework:recent-max-count
(lambda (p v)
(λ (p v)
(handler:size-recently-opened-files v)))
(preferences:set-default 'framework:last-url-string "" string?)
(preferences:set-default 'framework:recently-opened-sort-by 'age
(lambda (x) (or (eq? x 'age) (eq? x 'name))))
(λ (x) (or (eq? x 'age) (eq? x 'name))))
(preferences:set-default 'framework:recent-items-window-w 400 number?)
(preferences:set-default 'framework:recent-items-window-h 600 number?)
(preferences:set-default 'framework:open-here? #f boolean?)
@ -142,25 +142,25 @@
(preferences:set-default
'framework:print-output-mode
'standard
(lambda (x) (or (eq? x 'standard) (eq? x 'postscript))))
(λ (x) (or (eq? x 'standard) (eq? x 'postscript))))
(preferences:set-default 'framework:highlight-parens #t boolean?)
(preferences:set-default 'framework:fixup-parens #t boolean?)
(preferences:set-default 'framework:paren-match #t boolean?)
(let ([hash-table (make-hash-table)])
(for-each (lambda (x)
(for-each (λ (x)
(hash-table-put! hash-table x 'define))
'())
(for-each (lambda (x)
(for-each (λ (x)
(hash-table-put! hash-table x 'begin))
'(case-lambda
match-lambda match-lambda*
match-lambda match-lambda* λ
cond
delay
unit compound-unit compound-unit/sig
public private override
inherit sequence))
(for-each (lambda (x)
(for-each (λ (x)
(hash-table-put! hash-table x 'lambda))
'(
cases
@ -201,26 +201,26 @@
(preferences:set-default
'framework:tabify
(list hash-table #rx"^begin" #rx"^def" #f)
(lambda (x)
(λ (x)
(and (list? x)
(= (length x) 4)
(hash-table? (car x))
(andmap (lambda (x) (or (regexp? x) (not x))) (cdr x)))))
(andmap (λ (x) (or (regexp? x) (not x))) (cdr x)))))
(preferences:set-un/marshall
'framework:tabify
(lambda (t) (cons (hash-table-map (car t) list)
(λ (t) (cons (hash-table-map (car t) list)
(cdr t)))
(lambda (l)
(λ (l)
(and (list? l)
(= (length l) 4)
(andmap (lambda (x) (or (regexp? x) (not x)))
(andmap (λ (x) (or (regexp? x) (not x)))
(cdr l))
(andmap (lambda (x) (and (list? x)
(andmap (λ (x) (and (list? x)
(= 2 (length x))
(andmap symbol? x)))
(car l))
(let ([h (make-hash-table)])
(for-each (lambda (x) (apply hash-table-put! h x)) (car l))
(for-each (λ (x) (apply hash-table-put! h x)) (car l))
(cons h (cdr l)))))))
@ -235,13 +235,13 @@
(preferences:set-default
'framework:file-dialogs
'std
(lambda (x)
(λ (x)
(or (eq? x 'common)
(eq? x 'std))))
;; scheme prefs
(for-each (lambda (line)
(for-each (λ (line)
(let ([sym (car line)]
[color (cadr line)])
(color-prefs:register-color-pref (scheme:short-sym->pref-name sym)
@ -252,14 +252,14 @@
(preferences:set-default 'framework:default-text-color
(send the-color-database find-color "Black")
(lambda (x) (is-a? x color%)))
(λ (x) (is-a? x color%)))
(preferences:set-un/marshall 'framework:default-text-color
(lambda (c) (list (send c red) (send c green) (send c blue)))
(lambda (lst)
(λ (c) (list (send c red) (send c green) (send c blue)))
(λ (lst)
(make-object color% (car lst) (cadr lst) (caddr lst))))
(preferences:add-callback 'framework:default-text-color
(lambda (p v)
(λ (p v)
(editor:set-default-font-color v)))
;; groups
@ -267,17 +267,17 @@
(preferences:set-default 'framework:exit-when-no-frames #t boolean?)
(exit:insert-can?-callback
(lambda ()
(λ ()
(send (group:get-the-frame-group) can-close-all?)))
(exit:insert-on-callback
(lambda ()
(λ ()
(send (group:get-the-frame-group) on-close-all)
(preferences:silent-save) ;; the prefs may have changed as a result of closing the windows...
))
(exit:insert-can?-callback
(lambda ()
(λ ()
(or (preferences:save)
(exit-anyway?))))

10
collects/framework/private/number-snip.ss
View File

@ -464,19 +464,19 @@
(make-object checkable-menu-item%
(string-constant show-decimal-expansion)
menu
(lambda (x y) (set-fraction-view 'decimal)))]
(λ (x y) (set-fraction-view 'decimal)))]
[mixed-fraction-item
(make-object checkable-menu-item%
(string-constant show-mixed-fraction-view)
menu
(lambda (x y)
(λ (x y)
(set-fraction-view 'mixed)
(preferences:set 'framework:fraction-snip-style 'mixed)))]
[improper-fraction-item
(make-object checkable-menu-item%
(string-constant show-improper-fraction-view)
menu
(lambda (x y)
(λ (x y)
(set-fraction-view 'improper)
(preferences:set 'framework:fraction-snip-style 'improper)))])
@ -490,7 +490,7 @@
(make-object menu-item%
(string-constant show-more-decimal-places)
menu
(lambda (x y)
(λ (x y)
(iterate/reflow))))
menu))
@ -512,5 +512,5 @@
;; hash-table-bound? : hash-table TST -> boolean
(define (hash-table-bound? ht key)
(let/ec k
(hash-table-get ht key (lambda () (k #f)))
(hash-table-get ht key (λ () (k #f)))
#t)))))

34
collects/framework/private/panel.ss
View File

@ -35,7 +35,7 @@
;; would like to remove the child here, waiting on a PR submitted
;; about change-children during after-new-child
(change-children
(lambda (l)
(λ (l)
(remq c l)))
(error 'single-mixin::after-new-child
@ -51,7 +51,7 @@
[define/override (place-children l width height)
(let-values ([(h-align-spec v-align-spec) (get-alignment)])
(let ([align
(lambda (total-size spec item-size)
(λ (total-size spec item-size)
(floor
(case spec
[(center) (- (/ total-size 2) (/ item-size 2))]
@ -59,7 +59,7 @@
[(right bottom) (- total-size item-size)]
[else (error 'place-children
"alignment spec is unknown ~a~n" spec)])))])
(map (lambda (l)
(map (λ (l)
(let*-values ([(min-width min-height v-stretch? h-stretch?)
(apply values l)]
[(x this-width)
@ -85,7 +85,7 @@
(error 'active-child "got a panel that is not a child: ~e" x))
(unless (eq? x current-active-child)
(begin-container-sequence)
(for-each (lambda (x) (send x show #f))
(for-each (λ (x) (send x show #f))
(get-children))
(set! current-active-child x)
(send current-active-child show #t)
@ -97,12 +97,12 @@
(mixin (single<%> window<%>) (single-window<%>)
(inherit get-client-size get-size)
[define/override container-size
(lambda (l)
(λ (l)
(let-values ([(super-width super-height) (super container-size l)]
[(client-width client-height) (get-client-size)]
[(window-width window-height) (get-size)]
[(calc-size)
(lambda (super client window)
(λ (super client window)
(+ super (max 0 (- window client))))])
(values
@ -121,13 +121,13 @@
(init-field parent editor)
(public get-editor-canvas% get-vertical% get-horizontal%)
[define get-editor-canvas%
(lambda ()
(λ ()
editor-canvas%)]
[define get-vertical%
(lambda ()
(λ ()
vertical-panel%)]
[define get-horizontal%
(lambda ()
(λ ()
horizontal-panel%)]
(define/private (split p%)
@ -137,20 +137,20 @@
(is-a? canvas ec%)
(eq? (send canvas get-editor) editor))
(let ([p (send canvas get-parent)])
(send p change-children (lambda (x) null))
(send p change-children (λ (x) null))
(let ([pc (make-object p% p)])
(send (make-object ec% (make-object vertical-panel% pc) editor) focus)
(make-object ec% (make-object vertical-panel% pc) editor))))))
[define/public split-vertically
(lambda ()
(λ ()
(split (get-vertical%)))]
[define/public split-horizontally
(lambda ()
(λ ()
(split (get-horizontal%)))]
(public collapse)
(define collapse
(lambda ()
(λ ()
(let ([canvas (send (send parent get-top-level-window) get-edit-target-window)]
[ec% (get-editor-canvas%)])
(when (and canvas
@ -161,7 +161,7 @@
(bell)
(let* ([sp (send p get-parent)]
[p-to-remain (send sp get-parent)])
(send p-to-remain change-children (lambda (x) null))
(send p-to-remain change-children (λ (x) null))
(send (make-object ec% p-to-remain editor) focus))))))))
@ -257,7 +257,7 @@
(let ([len-children (length (get-children))])
(unless (= len-children (length percentages))
(let ([rat (/ 1 len-children)])
(set! percentages (build-list len-children (lambda (i) (make-percentage rat)))))
(set! percentages (build-list len-children (λ (i) (make-percentage rat)))))
(after-percentage-change))))
(define/override (after-new-child child)
@ -270,7 +270,7 @@
(define/override (on-subwindow-event receiver evt)
(if (eq? receiver this)
(let ([gap
(ormap (lambda (gap)
(ormap (λ (gap)
(and (<= (gap-before-dim gap)
(event-get-dim evt)
(gap-after-dim gap))
@ -321,7 +321,7 @@
[else
(let ([available-extent (get-available-extent)]
[show-error
(lambda (n)
(λ (n)
(error 'panel.ss::dragable-panel "internal error.~a" n))])
(let loop ([percentages percentages]
[children (get-children)]

2
collects/framework/private/path-utils.ss
View File

@ -53,7 +53,7 @@
[(and (eq? (system-type) 'windows)
(regexp-match #rx#"(.*)\\.[^.]*" name-bytes))
=>
(lambda (m)
(λ (m)
(build-path base (bytes->path (bytes-append (cadr m) #".bak"))))]
[(eq? (system-type) 'windows)
(build-path base (bytes->path (bytes-append name-bytes #".bak")))]

154
collects/framework/private/preferences.ss
View File

@ -70,7 +70,7 @@
p))
(hash-table-get preferences
p
(lambda ()
(λ ()
(let* ([def (hash-table-get defaults p)]
[def-val (default-value def)])
(hash-table-put! preferences p def-val)
@ -82,7 +82,7 @@
(define (set p value)
(let ([default (hash-table-get
defaults p
(lambda ()
(λ ()
(raise-unknown-preference-error
"preferences:set: tried to set the preference ~e to ~e, but no default is set"
p
@ -107,7 +107,7 @@
[unmarshall-fn (un/marshall-unmarshall
(hash-table-get marshall-unmarshall
p
(lambda () (k data))))]
(λ () (k data))))]
[default (hash-table-get defaults p)])
(let ([result (unmarshall-fn data)])
(if ((default-checker default) result)
@ -123,13 +123,13 @@
(hash-table-put! callbacks
p
(append
(hash-table-get callbacks p (lambda () null))
(hash-table-get callbacks p (λ () null))
(list new-cb)))
(lambda ()
(λ ()
(hash-table-put!
callbacks
p
(let loop ([callbacks (hash-table-get callbacks p (lambda () null))])
(let loop ([callbacks (hash-table-get callbacks p (λ () null))])
(cond
[(null? callbacks) null]
[else
@ -143,7 +143,7 @@
;; check-callbacks : sym val -> void
(define (check-callbacks p value)
(let ([new-callbacks
(let loop ([callbacks (hash-table-get callbacks p (lambda () null))])
(let loop ([callbacks (hash-table-get callbacks p (λ () null))])
(cond
[(null? callbacks) null]
[else
@ -165,7 +165,7 @@
(hash-table-put! callbacks p new-callbacks))))
(define set-un/marshall
(lambda (p marshall unmarshall)
(λ (p marshall unmarshall)
(unless (hash-table-bound? defaults p)
(error 'set-un/marshall "must call set-default for ~s before calling set-un/marshall for ~s"
p p))
@ -175,14 +175,14 @@
(define (hash-table-bound? ht s)
(let/ec k
(hash-table-get ht s (lambda () (k #f)))
(hash-table-get ht s (λ () (k #f)))
#t))
(define restore-defaults
(lambda ()
(λ ()
(hash-table-for-each
defaults
(lambda (p v) (set p v)))))
(λ (p v) (set p v)))))
;; set-default : (sym TST (TST -> boolean) -> void
(define (set-default p default-value checker)
@ -200,7 +200,7 @@
;; returns #t if the preference's value has been examined with set or get
(define (pref-has-value? p)
(let/ec k
(let ([b (hash-table-get preferences p (lambda () (k #f)))])
(let ([b (hash-table-get preferences p (λ () (k #f)))])
(not (marshalled? b)))))
@ -212,7 +212,7 @@
;; and result indicates if there was an error
(define (raw-save silent?)
(with-handlers ([exn:fail?
(lambda (exn)
(λ (exn)
(unless silent?
(message-box
(string-constant preferences)
@ -224,18 +224,18 @@
[res #t])
(put-preferences
syms vals
(lambda (filename)
(λ (filename)
(unless silent?
(let* ([d (make-object dialog% (string-constant preferences))]
[m (make-object message% (string-constant waiting-for-pref-lock) d)])
(thread
(lambda ()
(λ ()
(sleep 2)
(send d show #f)))
(send d show #t)
(put-preferences
syms vals
(lambda (filename)
(λ (filename)
(set! res #f)
(message-box
(string-constant preferences)
@ -250,7 +250,7 @@
(let* ([marshaller
(un/marshall-marshall
(hash-table-get marshall-unmarshall p
(lambda () (k (list p value)))))]
(λ () (k (list p value)))))]
[marshalled (marshaller value)])
(list p marshalled)))))
@ -281,7 +281,7 @@
;; get-disk-prefs/install : (-> A) -> (union A sexp)
(define (get-disk-prefs/install fail)
(let/ec k
(let ([sexp (get-disk-prefs (lambda () (k (fail))))])
(let ([sexp (get-disk-prefs (λ () (k (fail))))])
(install-stashed-preferences sexp '())
sexp)))
@ -290,7 +290,7 @@
(let/ec k
(let* ([filename (find-system-path 'pref-file)]
[mod (and (file-exists? filename) (file-or-directory-modify-seconds filename))]
[sexp (get-preference main-preferences-symbol (lambda () (k (fail))))])
[sexp (get-preference main-preferences-symbol (λ () (k (fail))))])
sexp)))
;; install-stashed-preferences : sexp (listof symbol) -> void
@ -299,7 +299,7 @@
(define (install-stashed-preferences prefs skip)
(for-each-pref-in-sexp
prefs
(lambda (p marshalled)
(λ (p marshalled)
(unless (memq p skip)
(let ([unmarshalled (unmarshall p (make-marshalled marshalled))])
(hash-table-put! preferences p unmarshalled)
@ -308,8 +308,8 @@
(define (for-each-pref-in-file parse-pref preferences-filename)
(let/ec k
(let ([input (with-handlers
([(lambda (x) #f) ;exn:fail?
(lambda (exn)
([(λ (x) #f) ;exn:fail?
(λ (exn)
(message-box
(string-constant error-reading-preferences)
(string-append
@ -373,7 +373,7 @@
(add-to-existing-children
titles
make-panel
(lambda (new-subtree) (set! ppanels (cons new-subtree ppanels))))))
(λ (new-subtree) (set! ppanels (cons new-subtree ppanels))))))
;; add-to-existing-children : (listof string) (panel -> panel) (ppanel -> void)
;; adds the child specified by the path in-titles to the tree.
@ -398,7 +398,7 @@
(ppanel-interior-children child)
(car titles)
(cdr titles)
(lambda (x)
(λ (x)
(set-ppanel-interior-children!
(cons
x
@ -407,7 +407,7 @@
(cdr children)
title
titles
(lambda (x)
(λ (x)
(set-cdr! children
(cons x (cdr children)))))))])))
@ -448,19 +448,19 @@
(define can-close-dialog-callbacks null)
(define (make-preferences-dialog)
(letrec ([stashed-prefs (get-disk-prefs/install (lambda () null))]
(letrec ([stashed-prefs (get-disk-prefs/install (λ () null))]
[frame-stashed-prefs%
(class frame:basic%
(define/override (show on?)
(when on?
(set! stashed-prefs (get-disk-prefs/install (lambda () null))))
(set! stashed-prefs (get-disk-prefs/install (λ () null))))
(super show on?))
(super-instantiate ()))]
[frame
(make-object frame-stashed-prefs%
(string-constant preferences))]
[build-ppanel-tree
(lambda (ppanel tab-panel single-panel)
(λ (ppanel tab-panel single-panel)
(send tab-panel append (ppanel-name ppanel))
(cond
[(ppanel-leaf? ppanel)
@ -468,10 +468,10 @@
[(ppanel-interior? ppanel)
(let-values ([(tab-panel single-panel) (make-tab/single-panel single-panel #t)])
(for-each
(lambda (ppanel) (build-ppanel-tree ppanel tab-panel single-panel))
(λ (ppanel) (build-ppanel-tree ppanel tab-panel single-panel))
(ppanel-interior-children ppanel)))]))]
[make-tab/single-panel
(lambda (parent inset?)
(λ (parent inset?)
(letrec ([spacer (and inset?
(instantiate vertical-panel% ()
(parent parent)
@ -479,7 +479,7 @@
[tab-panel (instantiate tab-panel% ()
(choices null)
(parent (if inset? spacer parent))
(callback (lambda (_1 _2)
(callback (λ (_1 _2)
(tab-panel-callback
single-panel
tab-panel))))]
@ -487,14 +487,14 @@
(parent tab-panel))])
(values tab-panel single-panel)))]
[tab-panel-callback
(lambda (single-panel tab-panel)
(λ (single-panel tab-panel)
(send single-panel active-child
(list-ref (send single-panel get-children)
(send tab-panel get-selection))))]
[panel (make-object vertical-panel% (send frame get-area-container))]
[_ (let-values ([(tab-panel single-panel) (make-tab/single-panel panel #f)])
(for-each
(lambda (ppanel)
(λ (ppanel)
(build-ppanel-tree ppanel tab-panel single-panel))
ppanels)
(let ([single-panel-children (send single-panel get-children)])
@ -503,15 +503,15 @@
(send tab-panel set-selection 0)))
(send tab-panel focus))]
[bottom-panel (make-object horizontal-panel% panel)]
[ok-callback (lambda args
(when (andmap (lambda (f) (f))
[ok-callback (λ args
(when (andmap (λ (f) (f))
can-close-dialog-callbacks)
(for-each
(lambda (f) (f))
(λ (f) (f))
on-close-dialog-callbacks)
(save)
(hide-dialog)))]
[cancel-callback (lambda (_1 _2)
[cancel-callback (λ (_1 _2)
(hide-dialog)
(install-stashed-preferences stashed-prefs '()))])
(gui-utils:ok/cancel-buttons
@ -528,17 +528,17 @@
(define (add-to-scheme-checkbox-panel f)
(set! scheme-panel-procs
(let ([old scheme-panel-procs])
(lambda (parent) (old parent) (f parent)))))
(λ (parent) (old parent) (f parent)))))
(define (add-to-editor-checkbox-panel f)
(set! editor-panel-procs
(let ([old editor-panel-procs])
(lambda (parent) (old parent) (f parent)))))
(λ (parent) (old parent) (f parent)))))
(define (add-to-warnings-checkbox-panel f)
(set! warnings-panel-procs
(let ([old warnings-panel-procs])
(lambda (parent) (old parent) (f parent)))))
(λ (parent) (old parent) (f parent)))))
(define scheme-panel-procs void)
(define editor-panel-procs void)
@ -547,7 +547,7 @@
(define (add-checkbox-panel label proc)
(add-panel
label
(lambda (parent)
(λ (parent)
(let* ([main (make-object vertical-panel% parent)])
(send main set-alignment 'left 'center)
(proc main)
@ -557,14 +557,14 @@
;; adds a check box preference to `main'.
(define (make-check main pref title bool->pref pref->bool)
(let* ([callback
(lambda (check-box _)
(λ (check-box _)
(set pref (bool->pref (send check-box get-value))))]
[pref-value (get pref)]
[initial-value (pref->bool pref-value)]
[c (make-object check-box% title main callback)])
(send c set-value initial-value)
(add-callback pref
(lambda (p v)
(λ (p v)
(send c set-value (pref->bool v))))))
(define (make-recent-items-slider parent)
@ -574,23 +574,23 @@
(min-value 1)
(max-value 100)
(init-value (get 'framework:recent-max-count))
(callback (lambda (slider y)
(callback (λ (slider y)
(set 'framework:recent-max-count
(send slider get-value)))))])
(add-callback
'framework:recent-max-count
(lambda (p v)
(λ (p v)
(send slider set-value v)))))
(define (add-scheme-checkbox-panel)
(letrec ([add-scheme-checkbox-panel
(lambda ()
(λ ()
(set! add-scheme-checkbox-panel void)
(add-checkbox-panel
(list
(string-constant editor-prefs-panel-label)
(string-constant scheme-prefs-panel-label))
(lambda (scheme-panel)
(λ (scheme-panel)
(make-check scheme-panel
'framework:highlight-parens
(string-constant highlight-parens)
@ -608,12 +608,12 @@
(define (add-editor-checkbox-panel)
(letrec ([add-editor-checkbox-panel
(lambda ()
(λ ()
(set! add-editor-checkbox-panel void)
(add-checkbox-panel
(list (string-constant editor-prefs-panel-label)
(string-constant general-prefs-panel-label))
(lambda (editor-panel)
(λ (editor-panel)
(make-recent-items-slider editor-panel)
(make-check editor-panel
'framework:autosaving-on?
@ -658,19 +658,19 @@
(make-check editor-panel
'framework:print-output-mode
(string-constant automatically-to-ps)
(lambda (b)
(λ (b)
(if b 'postscript 'standard))
(lambda (n) (eq? 'postscript n))))
(λ (n) (eq? 'postscript n))))
(editor-panel-procs editor-panel))))])
(add-editor-checkbox-panel)))
(define (add-warnings-checkbox-panel)
(letrec ([add-warnings-checkbox-panel
(lambda ()
(λ ()
(set! add-warnings-checkbox-panel void)
(add-checkbox-panel
(string-constant warnings-prefs-panel-label)
(lambda (warnings-panel)
(λ (warnings-panel)
(make-check warnings-panel
'framework:verify-change-format
(string-constant ask-before-changing-format)
@ -701,15 +701,15 @@
[(macosx) 13]
[else 12])]
[font-section "mred"]
[build-font-entry (lambda (x) (string-append "Screen" x "__"))]
[build-font-entry (λ (x) (string-append "Screen" x "__"))]
[font-file (find-graphical-system-path 'setup-file)]
[build-font-preference-symbol
(lambda (family)
(λ (family)
(string->symbol (string-append "framework:" family)))]
[set-default
(lambda (build-font-entry default pred)
(lambda (family)
(λ (build-font-entry default pred)
(λ (family)
(let ([name (build-font-preference-symbol family)]
[font-entry (build-font-entry family)])
(set-default name
@ -720,7 +720,7 @@
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
(add-callback
name
(lambda (p new-value)
(λ (p new-value)
(write-resource
font-section
font-entry
@ -732,26 +732,26 @@
(for-each (set-default build-font-entry font-default-string string?)
font-families)
((set-default (lambda (x) x)
((set-default (λ (x) x)
font-default-size
number?)
font-size-entry)
(add-panel
(string-constant default-fonts)
(lambda (parent)
(λ (parent)
(letrec ([font-size-pref-sym (build-font-preference-symbol font-size-entry)]
[ex-string (string-constant font-example-string)]
[main (make-object vertical-panel% parent)]
[fonts (cons font-default-string (get-face-list))]
[make-family-panel
(lambda (name)
(λ (name)
(let* ([pref-sym (build-font-preference-symbol name)]
[family-const-pair (assoc name font-families-name/const)]
[edit (make-object text%)]
[_ (send edit insert ex-string)]
[set-edit-font
(lambda (size)
(λ (size)
(let ([delta (make-object style-delta% 'change-size size)]
[face (get pref-sym)])
(if (and (string=? face font-default-string)
@ -779,7 +779,7 @@
(make-object button%
(string-constant change-font-button-label)
horiz
(lambda (button evt)
(λ (button evt)
(let ([new-value
(get-choices-from-user
(string-constant fonts)
@ -796,9 +796,9 @@
(set-edit-font (get font-size-pref-sym))
(add-callback
pref-sym
(lambda (p new-value)
(λ (p new-value)
(send horiz change-children
(lambda (l)
(λ (l)
(let ([new-message (make-object message%
new-value
horiz)])
@ -811,12 +811,12 @@
canvas))))))
(send canvas set-line-count 1)
(vector set-edit-font
(lambda () (send message get-width))
(lambda (width) (send message min-width width))
(lambda () (send label get-width))
(lambda (width) (send label min-width width)))))]
(λ () (send message get-width))
(λ (width) (send message min-width width))
(λ () (send label get-width))
(λ (width) (send label min-width width)))))]
[set-edit-fonts/messages (map make-family-panel font-families)]
[collect (lambda (n) (map (lambda (x) (vector-ref x n))
[collect (λ (n) (map (λ (x) (vector-ref x n))
set-edit-fonts/messages))]
[set-edit-fonts (collect 0)]
[font-message-get-widths (collect 1)]
@ -824,9 +824,9 @@
[category-message-get-widths (collect 3)]
[category-message-user-min-sizes (collect 4)]
[update-message-sizes
(lambda (gets sets)
(let ([width (foldl (lambda (x l) (max l (x))) 0 gets)])
(for-each (lambda (set) (set width)) sets)))]
(λ (gets sets)
(let ([width (foldl (λ (x l) (max l (x))) 0 gets)])
(for-each (λ (set) (set width)) sets)))]
[size-panel (make-object horizontal-panel% main '(border))]
[initial-font-size
(let ([b (box 0)])
@ -840,19 +840,19 @@
(string-constant font-size-slider-label)
1 127
size-panel
(lambda (slider evt)
(λ (slider evt)
(set font-size-pref-sym (send slider get-value)))
initial-font-size)])
(update-message-sizes font-message-get-widths font-message-user-min-sizes)
(update-message-sizes category-message-get-widths category-message-user-min-sizes)
(add-callback
font-size-pref-sym
(lambda (p value)
(for-each (lambda (f) (f value)) set-edit-fonts)
(λ (p value)
(for-each (λ (f) (f value)) set-edit-fonts)
(unless (= value (send size-slider get-value))
(send size-slider set-value value))
#t))
(for-each (lambda (f) (f initial-font-size)) set-edit-fonts)
(for-each (λ (f) (f initial-font-size)) set-edit-fonts)
(make-object message% (string-constant restart-to-see-font-changes) main)
main))))
(set! local-add-font-panel void))

192
collects/framework/private/scheme.ss
View File

@ -46,8 +46,8 @@
(opt-lambda (text [start 0] [in-end #f])
(let* ([end (or in-end (send text last-position))]
[port (open-input-text-editor text start end)])
(with-handlers ([exn:fail:read:eof? (lambda (x) #f)]
[exn:fail:read? (lambda (x) #t)])
(with-handlers ([exn:fail:read:eof? (λ (x) #f)]
[exn:fail:read? (λ (x) #t)])
(let loop ()
(let ([s (read port)])
(or (eof-object? s)
@ -74,7 +74,7 @@
(define/public (read-special file line col pos)
(let ([text (make-object text:basic%)])
(for-each
(lambda (s) (send text insert (send s copy)
(λ (s) (send text insert (send s copy)
(send text last-position)
(send text last-position)))
saved-snips)
@ -87,7 +87,7 @@
(opt-lambda (offset num [flattened? #f])
(if flattened?
(apply string-append
(map (lambda (snip)
(map (λ (snip)
(send snip get-text 0 (send snip get-count) flattened?))
saved-snips))
(super get-text offset num flattened?))))
@ -156,7 +156,7 @@
(keymap:add-to-right-button-menu
(let ([old (keymap:add-to-right-button-menu)])
(lambda (menu text event)
(λ (menu text event)
(old menu text event)
(split/collapse-text menu text event)
(void))))
@ -167,11 +167,11 @@
(let* ([on-it-box (box #f)]
[click-pos
(call-with-values
(lambda ()
(λ ()
(send text dc-location-to-editor-location
(send event get-x)
(send event get-y)))
(lambda (x y)
(λ (x y)
(send text find-position x y #f on-it-box)))]
[snip (send text find-snip click-pos 'after)]
[char (send text get-character click-pos)]
@ -209,7 +209,7 @@
(instantiate menu-item% ()
(parent menu)
(label (string-constant expand-sexp))
(callback (lambda (item evt) (expand-from text snip)))))
(callback (λ (item evt) (expand-from text snip)))))
;; expand-from : (instanceof text%) (instanceof sexp-snip<%>) -> void
(define (expand-from text snip)
@ -232,7 +232,7 @@
(instantiate menu-item% ()
(parent menu)
(label (string-constant collapse-sexp))
(callback (lambda (item evt)
(callback (λ (item evt)
(collapse-from text left-pos right-pos)))))
(define (collapse-from text left-pos right-pos)
@ -285,7 +285,7 @@
(define sn-hash (make-hash-table))
(define (short-sym->style-name sym)
(hash-table-get sn-hash sym
(lambda ()
(λ ()
(let ([s (format "framework:syntax-coloring:scheme:~a" sym)])
(hash-table-put! sn-hash sym s)
s))))
@ -293,9 +293,9 @@
(define (add-coloring-preferences-panel)
(color-prefs:add-to-preferences-panel
"Scheme"
(lambda (parent)
(λ (parent)
(for-each
(lambda (line)
(λ (line)
(let ([sym (car line)])
(color-prefs:build-color-selection-panel
parent
@ -341,7 +341,7 @@
set-tab-size))
(define init-wordbreak-map
(lambda (map)
(λ (map)
(let ([v (send map get-map #\-)])
(send map set-map
#\-
@ -442,7 +442,7 @@
(position-paragraph last))])
(letrec
([find-offset
(lambda (pos)
(λ (pos)
(let loop ([p pos][o 0])
(let ([c (get-character p)])
(cond
@ -455,7 +455,7 @@
[else
(cons o p)]))))]
[visual-offset
(lambda (pos)
(λ (pos)
(let loop ([p (sub1 pos)])
(if (= p -1)
0
@ -468,7 +468,7 @@
[(char=? c #\newline) 0]
[else (add1 (loop (sub1 p)))])))))]
[do-indent
(lambda (amt)
(λ (amt)
(let* ([pos-start end]
[curr-offset (find-offset pos-start)])
(unless (= amt (car curr-offset))
@ -477,26 +477,26 @@
(make-string amt #\space)
pos-start))))]
[get-proc
(lambda ()
(λ ()
(let ([id-end (forward-match contains (last-position))])
(if (and id-end (> id-end contains))
(let* ([text (get-text contains id-end)])
(or (get-keyword-type text)
'other)))))]
[procedure-indent
(lambda ()
(λ ()
(case (get-proc)
[(define) 1]
[(begin) 1]
[(lambda) 3]
[else 0]))]
[special-check
(lambda ()
(λ ()
(let* ([proc-name (get-proc)])
(or (eq? proc-name 'define)
(eq? proc-name 'lambda))))]
[indent-first-arg
(lambda (start)
(λ (start)
(car (find-offset start)))])
(when (and okay
(not (char=? (get-character (sub1 end))
@ -561,13 +561,13 @@
(let ([first-para (position-paragraph start-pos)]
[end-para (position-paragraph end-pos)])
(with-handlers ([exn:break?
(lambda (x) #t)])
(λ (x) #t)])
(dynamic-wind
(lambda ()
(λ ()
(when (< first-para end-para)
(begin-busy-cursor))
(begin-edit-sequence))
(lambda ()
(λ ()
(let loop ([para first-para])
(when (<= para end-para)
(tabify (paragraph-start-position para))
@ -583,7 +583,7 @@
(not (char=? next #\newline))))
(loop (add1 new-pos))
new-pos)))))
(lambda ()
(λ ()
(end-edit-sequence)
(when (< first-para end-para)
(end-busy-cursor))))))))
@ -739,31 +739,31 @@
(set-position pos pos)))
[define get-forward-sexp
(lambda (start-pos)
(λ (start-pos)
(forward-match start-pos (last-position)))]
[define remove-sexp
(lambda (start-pos)
(λ (start-pos)
(let ([end-pos (get-forward-sexp start-pos)])
(if end-pos
(kill 0 start-pos end-pos)
(bell)))
#t)]
[define forward-sexp
(lambda (start-pos)
(λ (start-pos)
(let ([end-pos (get-forward-sexp start-pos)])
(if end-pos
(set-position end-pos)
(bell))
#t))]
[define flash-forward-sexp
(lambda (start-pos)
(λ (start-pos)
(let ([end-pos (get-forward-sexp start-pos)])
(if end-pos
(flash-on end-pos (add1 end-pos))
(bell))
#t))]
[define get-backward-sexp
(lambda (start-pos)
(λ (start-pos)
(let* ([limit (get-limit start-pos)]
[end-pos
(backward-match start-pos limit)]
@ -777,21 +777,21 @@
#f)])
ans))]
[define flash-backward-sexp
(lambda (start-pos)
(λ (start-pos)
(let ([end-pos (get-backward-sexp start-pos)])
(if end-pos
(flash-on end-pos (add1 end-pos))
(bell))
#t))]
[define backward-sexp
(lambda (start-pos)
(λ (start-pos)
(let ([end-pos (get-backward-sexp start-pos)])
(if end-pos
(set-position end-pos)
(bell))
#t))]
[define find-up-sexp
(lambda (start-pos)
(λ (start-pos)
(let* ([limit-pos (get-limit start-pos)]
[exp-pos
(backward-containing-sexp start-pos limit-pos)])
@ -799,7 +799,7 @@
(if (and exp-pos (> exp-pos limit-pos))
(let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)]
[paren-pos
(lambda (paren-pair)
(λ (paren-pair)
(find-string
(car paren-pair)
'backward
@ -818,14 +818,14 @@
(- (apply max poss) 1)))) ;; subtract one to move outside the paren
#f)))]
[define up-sexp
(lambda (start-pos)
(λ (start-pos)
(let ([exp-pos (find-up-sexp start-pos)])
(if exp-pos
(set-position exp-pos)
(bell))
#t))]
[define find-down-sexp
(lambda (start-pos)
(λ (start-pos)
(let ([last (last-position)])
(let loop ([pos start-pos])
(let ([next-pos (forward-match pos last)])
@ -838,14 +838,14 @@
(loop next-pos)))
#f)))))]
[define down-sexp
(lambda (start-pos)
(λ (start-pos)
(let ([pos (find-down-sexp start-pos)])
(if pos
(set-position pos)
(bell))
#t))]
[define remove-parens-forward
(lambda (start-pos)
(λ (start-pos)
(let* ([pos (skip-whitespace start-pos 'forward #f)]
[first-char (get-character pos)]
[paren? (or (char=? first-char #\( )
@ -874,10 +874,10 @@
(public select-forward-sexp select-backward-sexp select-up-sexp select-down-sexp
transpose-sexp mark-matching-parenthesis)
[define select-forward-sexp (lambda () (select-text (lambda (x) (get-forward-sexp x)) #t))]
[define select-backward-sexp (lambda () (select-text (lambda (x) (get-backward-sexp x)) #f))]
[define select-up-sexp (lambda () (select-text (lambda (x) (find-up-sexp x)) #f))]
[define select-down-sexp (lambda () (select-text (lambda (x) (find-down-sexp x)) #t))]
[define select-forward-sexp (λ () (select-text (λ (x) (get-forward-sexp x)) #t))]
[define select-backward-sexp (λ () (select-text (λ (x) (get-backward-sexp x)) #f))]
[define select-up-sexp (λ () (select-text (λ (x) (find-up-sexp x)) #f))]
[define select-down-sexp (λ () (select-text (λ (x) (find-down-sexp x)) #t))]
(inherit get-fixed-style)
(define (mark-matching-parenthesis pos)
@ -900,7 +900,7 @@
(change-style matching-parenthesis-style (- end 1) end)])))))))
[define transpose-sexp
(lambda (pos)
(λ (pos)
(let ([start-1 (get-backward-sexp pos)])
(if (not start-1)
(bell)
@ -925,8 +925,8 @@
(end-edit-sequence)))))))))))]
[define tab-size 8]
(public get-tab-size set-tab-size)
[define get-tab-size (lambda () tab-size)]
[define set-tab-size (lambda (s) (set! tab-size s))]
[define get-tab-size (λ () tab-size)]
[define set-tab-size (λ (s) (set! tab-size s))]
(super-instantiate ())))
@ -985,7 +985,7 @@
(hash-table-get
ht
(string->symbol text)
(lambda ()
(λ ()
(cond
[(and beg-reg (regexp-match beg-reg text)) 'begin]
[(and def-reg (regexp-match def-reg text)) 'define]
@ -1019,54 +1019,54 @@
; ;
;; ;;;
(define setup-keymap
(lambda (keymap)
(λ (keymap)
(let ([add-pos-function
(lambda (name call-method)
(λ (name call-method)
(send keymap add-function name
(lambda (edit event)
(λ (edit event)
(call-method
edit
(send edit get-start-position)))))])
(add-pos-function "remove-sexp" (lambda (e p) (send e remove-sexp p)))
(add-pos-function "forward-sexp" (lambda (e p) (send e forward-sexp p)))
(add-pos-function "backward-sexp" (lambda (e p) (send e backward-sexp p)))
(add-pos-function "up-sexp" (lambda (e p) (send e up-sexp p)))
(add-pos-function "down-sexp" (lambda (e p) (send e down-sexp p)))
(add-pos-function "flash-backward-sexp" (lambda (e p) (send e flash-backward-sexp p)))
(add-pos-function "flash-forward-sexp" (lambda (e p) (send e flash-forward-sexp p)))
(add-pos-function "remove-parens-forward" (lambda (e p) (send e remove-parens-forward p)))
(add-pos-function "transpose-sexp" (lambda (e p) (send e transpose-sexp p)))
(add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p)))
(add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p)))
(add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p)))
(add-pos-function "up-sexp" (λ (e p) (send e up-sexp p)))
(add-pos-function "down-sexp" (λ (e p) (send e down-sexp p)))
(add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p)))
(add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p)))
(add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p)))
(add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p)))
(add-pos-function "mark-matching-parenthesis"
(lambda (e p) (send e mark-matching-parenthesis p))))
(λ (e p) (send e mark-matching-parenthesis p))))
(let ([add-edit-function
(lambda (name call-method)
(λ (name call-method)
(send keymap add-function name
(lambda (edit event)
(λ (edit event)
(call-method edit))))])
(add-edit-function "select-forward-sexp"
(lambda (x) (send x select-forward-sexp)))
(λ (x) (send x select-forward-sexp)))
(add-edit-function "select-backward-sexp"
(lambda (x) (send x select-backward-sexp)))
(λ (x) (send x select-backward-sexp)))
(add-edit-function "select-down-sexp"
(lambda (x) (send x select-down-sexp)))
(λ (x) (send x select-down-sexp)))
(add-edit-function "select-up-sexp"
(lambda (x) (send x select-up-sexp)))
(λ (x) (send x select-up-sexp)))
(add-edit-function "tabify-at-caret"
(lambda (x) (send x tabify-selection)))
(λ (x) (send x tabify-selection)))
(add-edit-function "do-return"
(lambda (x)
(λ (x)
(send x insert-return)))
(add-edit-function "comment-out"
(lambda (x) (send x comment-out-selection)))
(λ (x) (send x comment-out-selection)))
(add-edit-function "box-comment-out"
(lambda (x) (send x box-comment-out-selection)))
(λ (x) (send x box-comment-out-selection)))
(add-edit-function "uncomment"
(lambda (x) (send x uncomment-selection))))
(λ (x) (send x uncomment-selection))))
(send keymap add-function "balance-parens"
(lambda (edit event)
(λ (edit event)
(send edit balance-parens event)))
(send keymap map-function "TAB" "tabify-at-caret")
@ -1086,10 +1086,10 @@
(send keymap map-function "}" "balance-parens")
(let ([map-meta
(lambda (key func)
(λ (key func)
(keymap:send-map-function-meta keymap key func))]
[map
(lambda (key func)
(λ (key func)
(send keymap map-function key func))])
(map-meta "up" "up-sexp")
@ -1168,11 +1168,11 @@
(preferences:add-panel
(list (string-constant editor-prefs-panel-label)
(string-constant indenting-prefs-panel-label))
(lambda (p)
(λ (p)
(define get-keywords
(lambda (hash-table)
(λ (hash-table)
(letrec ([all-keywords (hash-table-map hash-table list)]
[pick-out (lambda (wanted in out)
[pick-out (λ (wanted in out)
(cond
[(null? in) (quicksort out string<=?)]
[else (if (eq? wanted (cadr (car in)))
@ -1184,22 +1184,22 @@
(define-values (begin-keywords define-keywords lambda-keywords)
(get-keywords (car (preferences:get 'framework:tabify))))
(define add-button-callback
(lambda (keyword-type keyword-symbol list-box)
(lambda (button command)
(λ (keyword-type keyword-symbol list-box)
(λ (button command)
(let ([new-one
(keymap:call/text-keymap-initializer
(lambda ()
(λ ()
(get-text-from-user
(format (string-constant enter-new-keyword) keyword-type)
(format (string-constant x-keyword) keyword-type))))])
(when new-one
(let ([parsed (with-handlers ((exn:fail:read? (lambda (x) #f)))
(let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f)))
(read (open-input-string new-one)))])
(cond
[(and (symbol? parsed)
(hash-table-get (car (preferences:get 'framework:tabify))
parsed
(lambda () #f)))
(λ () #f)))
(message-box (string-constant error)
(format (string-constant already-used-keyword) parsed))]
[(symbol? parsed)
@ -1210,30 +1210,30 @@
(string-constant error)
(format (string-constant expected-a-symbol) new-one))])))))))
(define delete-callback
(lambda (list-box)
(lambda (button command)
(λ (list-box)
(λ (button command)
(let* ([selections (send list-box get-selections)]
[symbols (map (lambda (x) (string->symbol (send list-box get-string x))) selections)])
(for-each (lambda (x) (send list-box delete x)) (reverse selections))
[symbols (map (λ (x) (string->symbol (send list-box get-string x))) selections)])
(for-each (λ (x) (send list-box delete x)) (reverse selections))
(let ([ht (car (preferences:get 'framework:tabify))])
(for-each (lambda (x) (hash-table-remove! ht x)) symbols))))))
(for-each (λ (x) (hash-table-remove! ht x)) symbols))))))
(define main-panel (make-object horizontal-panel% p))
(define make-column
(lambda (string symbol keywords bang-regexp)
(λ (string symbol keywords bang-regexp)
(let* ([vert (make-object vertical-panel% main-panel)]
[_ (make-object message% (format (string-constant x-like-keywords) string) vert)]
[box (make-object list-box% #f keywords vert void '(multiple))]
[button-panel (make-object horizontal-panel% vert)]
[text (new text-field%
(label (string-constant indenting-prefs-extra-regexp))
(callback (lambda (tf evt)
(callback (λ (tf evt)
(let ([str (send tf get-value)])
(cond
[(equal? str "")
(bang-regexp #f)]
[else
(with-handlers ([exn:fail?
(lambda (x)
(λ (x)
(color-yellow (send tf get-editor)))])
(bang-regexp (regexp str))
(clear-color (send tf get-editor)))]))))
@ -1259,32 +1259,32 @@
(make-column "Begin"
'begin
begin-keywords
(lambda (x) (set-car! (cdr (preferences:get 'framework:tabify)) x))))
(λ (x) (set-car! (cdr (preferences:get 'framework:tabify)) x))))
(define-values (define-list-box define-regexp-text)
(make-column "Define"
'define
define-keywords
(lambda (x) (set-car! (cddr (preferences:get 'framework:tabify)) x))))
(λ (x) (set-car! (cddr (preferences:get 'framework:tabify)) x))))
(define-values (lambda-list-box lambda-regexp-text)
(make-column "Lambda"
'lambda
lambda-keywords
(lambda (x) (set-car! (cdddr (preferences:get 'framework:tabify)) x))))
(λ (x) (set-car! (cdddr (preferences:get 'framework:tabify)) x))))
(define update-list-boxes
(lambda (hash-table)
(λ (hash-table)
(let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)]
[(reset) (lambda (list-box keywords)
[(reset) (λ (list-box keywords)
(send list-box clear)
(for-each (lambda (x) (send list-box append x)) keywords))])
(for-each (λ (x) (send list-box append x)) keywords))])
(reset begin-list-box begin-keywords)
(reset define-list-box define-keywords)
(reset lambda-list-box lambda-keywords)
#t)))
(define update-gui
(lambda (pref)
(λ (pref)
(update-list-boxes (car pref))
(send begin-regexp-text set-value (or (object-name (cadr pref)) ""))
(send define-regexp-text set-value (or (object-name (caddr pref)) ""))
(send lambda-regexp-text set-value (or (object-name (cadddr pref)) ""))))
(preferences:add-callback 'framework:tabify (lambda (p v) (update-gui v)))
(preferences:add-callback 'framework:tabify (λ (p v) (update-gui v)))
main-panel))))))

50
collects/framework/private/standard-menus-items.ss
View File

@ -100,7 +100,7 @@
(format "~a:~a-help-string" (menu-item-menu-name item) (an-item-item-name item))))
(define (edit-menu:do const)
`(lambda (menu evt)
`(λ (menu evt)
(let ([edit (get-edit-target-object)])
(when (and edit
(is-a? edit editor<%>))
@ -108,7 +108,7 @@
#t))
(define (edit-menu:can-do-on-demand const)
`(lambda (item)
`(λ (item)
(let* ([editor (get-edit-target-object)]
[enable?
(and editor
@ -117,12 +117,12 @@
(send item enable enable?))))
(define edit-menu:edit-target-on-demand
`(lambda (item)
`(λ (item)
(send item enable
(let ([target (get-edit-target-object)])
(and target (is-a? target editor<%>))))))
(define on-demand-do-nothing '(lambda (menu-item) (void)))
(define on-demand-do-nothing '(λ (menu-item) (void)))
(define items
(list (make-generic-augment
@ -133,7 +133,7 @@
'("@return : void"
"Removes the preferences callbacks for the menu items"))
(make-generic-method
'get-menu% '(lambda () menu:can-restore-underscore-menu%)
'get-menu% '(λ () menu:can-restore-underscore-menu%)
'("The result of this method is used as the class"
"for creating the result of these methods:"
"@ilink frame:standard-menus get-file-menu %"
@ -148,7 +148,7 @@
"defaultly returns"
"@link menu"))
(make-generic-method
'get-menu-item% '(lambda () menu:can-restore-menu-item%)
'get-menu-item% '(λ () menu:can-restore-menu-item%)
'("The result of this method is used as the class for creating"
"the menu items in this frame (see "
"@link frame:standard-menus"
@ -160,7 +160,7 @@
"@link menu:can-restore-menu-item %"
"."))
(make-generic-method
'get-checkable-menu-item% '(lambda () menu:can-restore-checkable-menu-item%)
'get-checkable-menu-item% '(λ () menu:can-restore-checkable-menu-item%)
'("The result of this method is used as the class for creating"
"checkable menu items in this class (see "
"@link frame:standard-menus"
@ -174,7 +174,7 @@
(make-generic-method
'get-file-menu
'(lambda () file-menu)
'(λ () file-menu)
'("Returns the file menu"
"See also"
"@ilink frame:standard-menus get-menu\\%"
@ -189,7 +189,7 @@
(get-menu-bar)))
(make-generic-method
'get-edit-menu
'(lambda () edit-menu)
'(λ () edit-menu)
'("Returns the edit menu"
"See also"
@ -201,7 +201,7 @@
'(make-object (get-menu%) (string-constant edit-menu-label) (get-menu-bar)))
(make-generic-method
'get-help-menu
'(lambda () help-menu)
'(λ () help-menu)
'("Returns the help menu"
"See also"
@ -214,30 +214,30 @@
(make-an-item 'file-menu 'new
'(string-constant new-info)
'(lambda (item control) (handler:edit-file #f) #t)
'(λ (item control) (handler:edit-file #f) #t)
#\n
'(string-constant new-menu-item)
on-demand-do-nothing
#t)
(make-between 'file-menu 'new 'open 'nothing)
(make-an-item 'file-menu 'open '(string-constant open-info)
'(lambda (item control) (handler:open-file) #t)
'(λ (item control) (handler:open-file) #t)
#\o
'(string-constant open-menu-item)
on-demand-do-nothing
#t)
(make-a-submenu-item 'file-menu 'open-recent
'(string-constant open-recent-info)
'(lambda (x y) (void))
'(λ (x y) (void))
#f
'(string-constant open-recent-menu-item)
'(lambda (menu)
'(λ (menu)
(handler:install-recent-items menu))
#t)
(make-between 'file-menu 'open 'revert 'nothing)
(make-an-item 'file-menu 'revert
'(string-constant revert-info)
'(lambda (item control) (void))
'(λ (item control) (void))
#f
'(string-constant revert-menu-item)
on-demand-do-nothing
@ -245,14 +245,14 @@
(make-between 'file-menu 'revert 'save 'nothing)
(make-an-item 'file-menu 'save
'(string-constant save-info)
'(lambda (item control) (void))
'(λ (item control) (void))
#\s
'(string-constant save-menu-item)
on-demand-do-nothing
#f)
(make-an-item 'file-menu 'save-as
'(string-constant save-as-info)
'(lambda (item control) (void))
'(λ (item control) (void))
#f
'(string-constant save-as-menu-item)
on-demand-do-nothing
@ -260,7 +260,7 @@
(make-between 'file-menu 'save-as 'print 'nothing)
(make-an-item 'file-menu 'print
'(string-constant print-info)
'(lambda (item control) (void))
'(λ (item control) (void))
#\p
'(string-constant print-menu-item)
on-demand-do-nothing
@ -268,7 +268,7 @@
(make-between 'file-menu 'print 'close 'separator)
(make-an-item 'file-menu 'close
'(string-constant close-info)
'(lambda (item control) (when (can-close?) (on-close) (show #f)) #t)
'(λ (item control) (when (can-close?) (on-close) (show #f)) #t)
#\w
'(string-constant close-menu-item)
on-demand-do-nothing
@ -276,7 +276,7 @@
(make-between 'file-menu 'close 'quit 'nothing)
(make-an-item 'file-menu 'quit
'(string-constant quit-info)
'(lambda (item control)
'(λ (item control)
(when (exit:user-oks-exit)
(exit:exit)))
#\q
@ -346,21 +346,21 @@
(make-an-item 'edit-menu 'find
'(string-constant find-info)
'(lambda (item control) (void))
'(λ (item control) (void))
#\f
'(string-constant find-menu-item)
edit-menu:edit-target-on-demand
#f)
(make-an-item 'edit-menu 'find-again
'(string-constant find-again-info)
'(lambda (item control) (void))
'(λ (item control) (void))
#\g
'(string-constant find-again-menu-item)
edit-menu:edit-target-on-demand
#f)
(make-an-item 'edit-menu 'replace-and-find-again
'(string-constant replace-and-find-again-info)
'(lambda (item control) (void))
'(λ (item control) (void))
'(if (eq? (system-type) 'macosx) #f #\h)
'(string-constant replace-and-find-again-menu-item)
edit-menu:edit-target-on-demand
@ -369,7 +369,7 @@
(make-between 'edit-menu 'find 'preferences 'nothing-with-standard-menus)
(make-an-item 'edit-menu 'preferences
'(string-constant preferences-info)
'(lambda (item control) (preferences:show-dialog) #t)
'(λ (item control) (preferences:show-dialog) #t)
#\;
'(string-constant preferences-menu-item)
on-demand-do-nothing
@ -379,7 +379,7 @@
(make-before 'help-menu 'about 'nothing)
(make-an-item 'help-menu 'about
'(string-constant about-info)
'(lambda (item control) (void))
'(λ (item control) (void))
#f
'(string-constant about-menu-item)
on-demand-do-nothing

98
collects/framework/private/text.ss
View File

@ -108,7 +108,7 @@ WARNING: printf is rebound in the body of the unit to always
(let-values ([(this-left this-right)
(send (car canvases)
call-as-primary-owner
(lambda ()
(λ ()
(send (get-admin) get-view b1 b2 b3 b4)
(let* ([this-left (unbox b1)]
[this-width (unbox b3)]
@ -167,7 +167,7 @@ WARNING: printf is rebound in the body of the unit to always
(let* ([b1 (box 0)]
[b2 (box 0)]
[new-rectangles
(lambda (range)
(λ (range)
(let* ([start (range-start range)]
[end (range-end range)]
[b/w-bitmap (range-b/w-bitmap range)]
@ -227,13 +227,13 @@ WARNING: printf is rebound in the body of the unit to always
[old-rectangles range-rectangles])
(set! range-rectangles
(foldl (lambda (x l) (append (new-rectangles x) l))
(foldl (λ (x l) (append (new-rectangles x) l))
null ranges))))
(define/public highlight-range
(opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
(unless (let ([exact-pos-int?
(lambda (x) (and (integer? x) (exact? x) (x . >= . 0)))])
(λ (x) (and (integer? x) (exact? x) (x . >= . 0)))])
(and (exact-pos-int? start)
(exact-pos-int? end)))
(error 'highlight-range "expected first two arguments to be non-negative exact integers, got: ~e ~e"
@ -246,7 +246,7 @@ WARNING: printf is rebound in the body of the unit to always
(set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l))))
(recompute-range-rectangles)
(invalidate-rectangles range-rectangles)
(lambda ()
(λ ()
(let ([old-rectangles range-rectangles])
(set! ranges
(let loop ([r ranges])
@ -265,7 +265,7 @@ WARNING: printf is rebound in the body of the unit to always
[b3 (box 0)]
[b4 (box 0)])
(for-each
(lambda (rectangle)
(λ (rectangle)
(let-values ([(view-x view-y view-width view-height)
(begin
(send (get-admin) get-view b1 b2 b3 b4)
@ -291,7 +291,7 @@ WARNING: printf is rebound in the body of the unit to always
rc
#f))
rc))]
[first-number (lambda (x y) (if (number? x) x y))]
[first-number (λ (x y) (if (number? x) x y))]
[left (max left-margin (first-number (rectangle-left rectangle) view-x))]
[top (max top-margin (rectangle-top rectangle))]
[right (min right-margin
@ -519,8 +519,8 @@ WARNING: printf is rebound in the body of the unit to always
(cond
[(zero? n)
(if blank?
(lambda (dc x y) (void))
(lambda (dc x y)
(λ (dc x y) (void))
(λ (dc x y)
(send dc draw-line (+ x n) y (+ x n (- len 1)) y)))]
[else
(let ([white? (char-whitespace? (string-ref str (- n 1)))])
@ -531,7 +531,7 @@ WARNING: printf is rebound in the body of the unit to always
(let ([res (loop (- n 1) 1 (not blank?))])
(if blank?
res
(lambda (dc x y)
(λ (dc x y)
(send dc draw-line (+ x n) y (+ x n (- len 1)) y)
(res dc x y))))]))])))
@ -644,7 +644,7 @@ WARNING: printf is rebound in the body of the unit to always
(send delegate last-position))
(loop (send snip next)))))
(for-each
(lambda (range)
(λ (range)
(send delegate highlight-range
(range-start range)
(range-end range)
@ -662,7 +662,7 @@ WARNING: printf is rebound in the body of the unit to always
(if delegate
(let ([delegate-res (send delegate highlight-range
start end color bitmap caret-space? priority)])
(lambda ()
(λ ()
(res)
(delegate-res)))
res))))
@ -690,7 +690,7 @@ WARNING: printf is rebound in the body of the unit to always
(when (and delegate
linked-snips
(not (is-a? snip string-snip%)))
(let ([delegate-copy (hash-table-get linked-snips snip (lambda () #f))])
(let ([delegate-copy (hash-table-get linked-snips snip (λ () #f))])
(when delegate-copy
(send delegate resized delegate-copy redraw-now?)))))
@ -754,7 +754,7 @@ WARNING: printf is rebound in the body of the unit to always
(define/private (enqueue-for-frame call-method tag)
(run-after-edit-sequence
(rec from-enqueue-for-frame
(lambda ()
(λ ()
(call-with-frame call-method)))
tag))
@ -770,12 +770,12 @@ WARNING: printf is rebound in the body of the unit to always
(define/override (set-anchor x)
(super set-anchor x)
(enqueue-for-frame
(lambda (x) (send x anchor-status-changed))
(λ (x) (send x anchor-status-changed))
'framework:anchor-status-changed))
(define/override (set-overwrite-mode x)
(super set-overwrite-mode x)
(enqueue-for-frame
(lambda (x) (send x overwrite-status-changed))
(λ (x) (send x overwrite-status-changed))
'framework:overwrite-status-changed))
(define/augment (after-set-position)
(maybe-queue-editor-position-update)
@ -787,11 +787,11 @@ WARNING: printf is rebound in the body of the unit to always
(define callback-running? #f)
(define/private (maybe-queue-editor-position-update)
(enqueue-for-frame
(lambda (frame)
(λ (frame)
(unless callback-running?
(set! callback-running? #t)
(queue-callback
(lambda ()
(λ ()
(send frame editor-position-changed)
(set! callback-running? #f))
#f)))
@ -1061,12 +1061,12 @@ WARNING: printf is rebound in the body of the unit to always
(for-each/snips-chars
unread-start-point
(last-position)
(lambda (s/c line-col-pos)
(λ (s/c line-col-pos)
(cond
[(is-a? s/c snip%)
(channel-put read-chan (cons s/c line-col-pos))]
[(char? s/c)
(for-each (lambda (b) (channel-put read-chan (cons b line-col-pos)))
(for-each (λ (b) (channel-put read-chan (cons b line-col-pos)))
(bytes->list (string->bytes/utf-8 (string s/c))))])))
(set! allow-tabify? #f)
(set! allow-tabify? #t)
@ -1110,7 +1110,7 @@ WARNING: printf is rebound in the body of the unit to always
(define/private (queue-insertion txts signal)
(parameterize ([current-eventspace eventspace])
(queue-callback
(lambda ()
(λ ()
(do-insertion txts)
(sync signal)))))
@ -1161,7 +1161,7 @@ WARNING: printf is rebound in the body of the unit to always
(define output-buffer-thread
(let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")])
(thread
(lambda ()
(λ ()
(let loop (;; text-to-insert : (queue (cons (union snip bytes) style))
[text-to-insert (empty-queue)]
[last-flush (current-inexact-milliseconds)])
@ -1171,7 +1171,7 @@ WARNING: printf is rebound in the body of the unit to always
never-evt
(handle-evt
(alarm-evt (+ last-flush msec-timeout))
(lambda (_)
(λ (_)
(dprintf show-dprintf? "o: alarm.1 ~s\n" (queue->list text-to-insert))
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(dprintf show-dprintf? "o: alarm.2 ~s\n" viable-bytes)
@ -1179,7 +1179,7 @@ WARNING: printf is rebound in the body of the unit to always
(loop remaining-queue (current-inexact-milliseconds))))))
(handle-evt
flush-chan
(lambda (return-evt)
(λ (return-evt)
(dprintf show-dprintf? "o: flush.1 ~s\n" (queue->list text-to-insert))
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(dprintf show-dprintf? "o: flush.2 ~s\n" viable-bytes)
@ -1187,12 +1187,12 @@ WARNING: printf is rebound in the body of the unit to always
(loop remaining-queue (current-inexact-milliseconds)))))
(handle-evt
clear-output-chan
(lambda (_)
(λ (_)
(dprintf show-dprintf? "o: clear-output\n")
(loop (empty-queue) (current-inexact-milliseconds))))
(handle-evt
write-chan
(lambda (pr)
(λ (pr)
(dprintf show-dprintf? "o: write ~s\n" pr)
(let ([new-text-to-insert (enqueue pr text-to-insert)])
(cond
@ -1220,7 +1220,7 @@ WARNING: printf is rebound in the body of the unit to always
;; in any thread (even concurrently)
;;
(define (make-write-bytes-proc style)
(lambda (to-write start end block/buffer? enable-breaks?)
(λ (to-write start end block/buffer? enable-breaks?)
(cond
[(= start end) (flush-proc)]
[(eq? (current-thread) (eventspace-handler-thread eventspace))
@ -1236,7 +1236,7 @@ WARNING: printf is rebound in the body of the unit to always
[else
(sync
(nack-guard-evt
(lambda (fail-channel)
(λ (fail-channel)
(let* ([return-channel (make-channel)]
[return-evt
(choice-evt
@ -1249,7 +1249,7 @@ WARNING: printf is rebound in the body of the unit to always
(void))
(define (make-write-special-proc style)
(lambda (special can-buffer? enable-breaks?)
(λ (special can-buffer? enable-breaks?)
(cond
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'write-bytes-proc "cannot write to port on eventspace main thread")]
@ -1258,7 +1258,7 @@ WARNING: printf is rebound in the body of the unit to always
#t))
(let* ([add-standard
(lambda (sd)
(λ (sd)
(let* ([style-list (get-style-list)]
[std (send style-list find-named-style "Standard")])
(if std
@ -1312,7 +1312,7 @@ WARNING: printf is rebound in the body of the unit to always
(define input-buffer-thread
(thread
(lambda ()
(λ ()
;; these vars are like arguments to the loop function
;; they are only set right before loop is called.
@ -1346,7 +1346,7 @@ WARNING: printf is rebound in the body of the unit to always
(sync
(handle-evt
position-chan
(lambda (pr)
(λ (pr)
(dprintf show-dprintf? "i: position-chan\n")
(let ([nack-chan (car pr)]
[resp-chan (cdr pr)])
@ -1357,7 +1357,7 @@ WARNING: printf is rebound in the body of the unit to always
never-evt)
(handle-evt
read-chan
(lambda (ent)
(λ (ent)
(dprintf show-dprintf? "i: read-chan\n")
(set! data (enqueue ent data))
(unless position
@ -1365,7 +1365,7 @@ WARNING: printf is rebound in the body of the unit to always
(loop)))
(handle-evt
clear-input-chan
(lambda (_)
(λ (_)
(dprintf show-dprintf? "i: clear-input-chan\n")
(semaphore-post peeker-sema)
(set! peeker-sema (make-semaphore 0))
@ -1375,7 +1375,7 @@ WARNING: printf is rebound in the body of the unit to always
(loop)))
(handle-evt
progress-event-chan
(lambda (return-pr)
(λ (return-pr)
(dprintf show-dprintf? "i: progress-event-chan\n")
(let ([return-chan (car return-pr)]
[return-nack (cdr return-pr)])
@ -1387,20 +1387,20 @@ WARNING: printf is rebound in the body of the unit to always
(loop))))
(handle-evt
peek-chan
(lambda (peeker)
(λ (peeker)
(dprintf show-dprintf? "i: peek-chan\n")
(set! peekers (cons peeker peekers))
(loop)))
(handle-evt
commit-chan
(lambda (committer)
(λ (committer)
(dprintf show-dprintf? "i:commit-chan\n")
(set! committers (cons committer committers))
(loop)))
(apply
choice-evt
(map
(lambda (a-committer)
(λ (a-committer)
(match a-committer
[($ committer
kr
@ -1411,13 +1411,13 @@ WARNING: printf is rebound in the body of the unit to always
(choice-evt
(handle-evt
commit-peeker-evt
(lambda (_)
(λ (_)
(dprintf show-dprintf? "i: commit-peeker-evt\n")
;; this committer will be thrown out in next iteration
(loop)))
(handle-evt
done-evt
(lambda (v)
(λ (v)
(dprintf show-dprintf? "i: done-evt\n")
(let ([nth-pos (cdr (peek-n data (- kr 1)))])
(set! position
@ -1438,10 +1438,10 @@ WARNING: printf is rebound in the body of the unit to always
(loop))))]))
committers))
(apply choice-evt
(map (lambda (resp-evt)
(map (λ (resp-evt)
(handle-evt
resp-evt
(lambda (_)
(λ (_)
(dprintf show-dprintf? "i: resp-evt\n")
(set! response-evts (remq resp-evt response-evts))
(loop))))
@ -1455,7 +1455,7 @@ WARNING: printf is rebound in the body of the unit to always
(choice-evt nack-evt
(channel-put-evt resp-evt position))
(let ([sent-position position])
(lambda (_)
(λ (_)
(set! positioners (remq pr positioners))
(loop))))))
@ -1503,7 +1503,7 @@ WARNING: printf is rebound in the body of the unit to always
[else
(channel-put-evt
resp-chan
(lambda (src line col pos)
(λ (src line col pos)
(if (is-a? nth readable-snip<%>)
(send nth read-special src line col pos)
nth)))])))]
@ -1546,7 +1546,7 @@ WARNING: printf is rebound in the body of the unit to always
[(sync/timeout 0 progress-evt) 0]
[else (wrap-evt
v
(lambda (v)
(λ (v)
(if (and (number? v) (zero? v))
0
(if (commit-proc (if (number? v) v 1)
@ -1557,7 +1557,7 @@ WARNING: printf is rebound in the body of the unit to always
(define (peek-proc bstr skip-count progress-evt)
(nack-guard-evt
(lambda (nack)
(λ (nack)
(let ([chan (make-channel)])
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack))
chan))))
@ -1565,7 +1565,7 @@ WARNING: printf is rebound in the body of the unit to always
(define (progress-evt-proc)
(sync
(nack-guard-evt
(lambda (nack)
(λ (nack)
(let ([chan (make-channel)])
(channel-put progress-event-chan (cons chan nack))
chan)))))
@ -1573,7 +1573,7 @@ WARNING: printf is rebound in the body of the unit to always
(define (commit-proc kr progress-evt done-evt)
(sync
(nack-guard-evt
(lambda (nack)
(λ (nack)
(let ([chan (make-channel)])
(channel-put commit-chan (make-committer kr progress-evt done-evt chan nack))
chan)))))
@ -1586,7 +1586,7 @@ WARNING: printf is rebound in the body of the unit to always
values
(sync
(nack-guard-evt
(lambda (fail)
(λ (fail)
(channel-put position-chan (cons fail chan))
chan))))))

6
collects/framework/private/version.ss
View File

@ -15,9 +15,9 @@
(define specs null)
(define -version
(lambda ()
(λ ()
(foldr
(lambda (entry sofar)
(λ (entry sofar)
(let ([sep (first entry)]
[num (second entry)])
(string-append sofar sep num)))
@ -25,6 +25,6 @@
specs)))
(define add-spec
(lambda (sep num)
(λ (sep num)
(set! specs (cons (list (expr->string sep) (format "~a" num))
specs)))))))

16
collects/framework/splash.ss
View File

@ -82,11 +82,11 @@
(send splash-frame show #f)))
(define (shutdown-splash)
(set! splash-load-handler (lambda (old-load f expected) (old-load f expected))))
(set! splash-load-handler (λ (old-load f expected) (old-load f expected))))
(define funny?
(let ([date (seconds->date (current-seconds))])
(and (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
(and (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(collection-path "icons")
#t)
(= (date-day date) 25)
@ -111,7 +111,7 @@
(current-load
(let ([old-load (current-load)])
(lambda (f expected)
(λ (f expected)
(splash-load-handler old-load f expected))))
(when (and make-compilation-manager-load/use-compiled-handler
@ -122,7 +122,7 @@
(equal? (getenv "PLTDRDEBUG") "trace"))
(printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n")
(manager-trace-handler
(lambda (x) (display "2: ") (display x) (newline))))))
(λ (x) (display "2: ") (display x) (newline))))))
(define funny-gauge%
(class canvas%
@ -133,9 +133,9 @@
(make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))]
[max-value 1])
[define/public set-range (lambda (r) (set! max-value r))]
[define/public set-range (λ (r) (set! max-value r))]
[define/public set-value
(lambda (new-value)
(λ (new-value)
(let* ([before-x
(floor (* (send funny-bitmap get-width) (/ funny-value max-value)))]
[after-x
@ -173,7 +173,7 @@
(define (splash-get-preference name default)
(get-preference
name
(lambda ()
(λ ()
default)))
(define (splash-set-preference name value)
(put-preferences (list name) (list value)))
@ -210,7 +210,7 @@
(if splash-bitmap
(send dc draw-bitmap splash-bitmap 0 0)
(send dc clear))
(for-each (lambda (icon)
(for-each (λ (icon)
(send dc draw-bitmap
(icon-bm icon)
(icon-x icon)

116
collects/framework/test.ss
View File

@ -80,22 +80,22 @@
;; ((frame-has? p) f) =
;; f is a frame and it has a child (in it or a subpanel) that responds #t to p
(test:button-push
((union (lambda (str)
((union (λ (str)
(and (string? str)
(test:top-level-focus-window-has?
(lambda (c)
(λ (c)
(and (is-a? c button%)
(string=? (send c get-label) str)
(send c is-enabled?)
(send c is-shown?))))))
(and/c (is-a?/c button%)
(lambda (btn)
(λ (btn)
(and (send btn is-enabled?)
(send btn is-shown?)))
(lambda (btn)
(λ (btn)
(test:top-level-focus-window-has?
(lambda (c) (eq? c btn))))))
(λ (c) (eq? c btn))))))
. -> .
void?)
(button)
@ -245,9 +245,9 @@
;;
(define install-timer
(lambda (msec thunk)
(λ (msec thunk)
(let ([timer (instantiate timer% ()
[notify-callback (lambda () (thunk))])])
[notify-callback (λ () (thunk))])])
(send timer start msec #t))))
;;
@ -274,19 +274,19 @@
[the-error #f]) ;; boxed exn struct, or else #f.
(letrec
([begin-action
(lambda ()
(λ ()
(semaphore-wait sem)
(set! count (add1 count))
(semaphore-post sem))]
[end-action
(lambda ()
(λ ()
(semaphore-wait sem)
(set! count (sub1 count))
(semaphore-post sem))]
[end-action-with-error
(lambda (exn)
(λ (exn)
(semaphore-wait sem)
(set! count (sub1 count))
(unless the-error
@ -294,7 +294,7 @@
(semaphore-post sem))]
[get-exn-box
(lambda ()
(λ ()
(semaphore-wait sem)
(let ([ans the-error])
(set! the-error #f)
@ -302,14 +302,14 @@
ans))]
[is-exn?
(lambda ()
(λ ()
(semaphore-wait sem)
(let ([ans (if the-error #t #f)])
(semaphore-post sem)
ans))]
[num-actions
(lambda ()
(λ ()
(semaphore-wait sem)
(let ([ans (+ count (if the-error 1 0))])
(semaphore-post sem)
@ -323,7 +323,7 @@
(define number-pending-actions num-actions)
(define reraise-error
(lambda ()
(λ ()
(let ([exn-box (get-exn-box)])
(if exn-box (raise (unbox exn-box)) (void)))))
@ -340,15 +340,15 @@
[thread-semaphore (make-semaphore 0)])
(thread
(rec loop
(lambda ()
(λ ()
(semaphore-wait thread-semaphore)
(sleep)
(semaphore-post yield-semaphore)
(loop))))
(lambda (thunk)
(λ (thunk)
(let ([sem (make-semaphore 0)])
(letrec ([start
(lambda () ;; eventspace main thread
(λ () ;; eventspace main thread
;; guarantee (probably) that some events are handled
(semaphore-post thread-semaphore)
@ -358,13 +358,13 @@
(unless (is-exn?)
(begin-action)
(parameterize ([current-exception-handler
(lambda (exn)
(λ (exn)
(end-action-with-error exn)
((error-escape-handler)))])
(thunk))
(end-action)))]
[return (lambda () (semaphore-post sem))])
[return (λ () (semaphore-post sem))])
(install-timer 0 start)
(semaphore-wait sem)
@ -376,25 +376,25 @@
[thread-semaphore (make-semaphore 0)])
(thread
(rec loop
(lambda ()
(λ ()
(semaphore-wait thread-semaphore)
(sleep)
(semaphore-post yield-semaphore)
(loop))))
(lambda (thunk)
(λ (thunk)
(let ([done (make-semaphore 0)])
(queue-callback
(lambda ()
(λ ()
;; guarantee (probably) that some events are handled
(semaphore-post thread-semaphore)
(yield yield-semaphore)
(queue-callback (lambda () (semaphore-post done)))
(queue-callback (λ () (semaphore-post done)))
(unless (is-exn?)
(begin-action)
(parameterize ([current-exception-handler
(lambda (exn)
(λ (exn)
(end-action-with-error exn)
((error-escape-handler)))])
(thunk))
@ -402,10 +402,10 @@
(semaphore-wait done)))))
(define current-get-eventspaces
(make-parameter (lambda () (list (current-eventspace)))))
(make-parameter (λ () (list (current-eventspace)))))
(define (get-active-frame)
(ormap (lambda (eventspace)
(ormap (λ (eventspace)
(parameterize ([current-eventspace eventspace])
(get-top-level-focus-window)))
((current-get-eventspaces))))
@ -426,7 +426,7 @@
;;
(define ancestor-list
(lambda (window stop-at-top-level-window?)
(λ (window stop-at-top-level-window?)
(let loop ([w window] [l null])
(if (or (not w)
(and stop-at-top-level-window?
@ -440,7 +440,7 @@
;;
(define in-active-frame?
(lambda (window)
(λ (window)
(let ([frame (get-active-frame)])
(let loop ([window window])
(cond [(null? window) #f]
@ -454,13 +454,13 @@
;;
(define verify-list
(lambda (l valid)
(λ (l valid)
(cond [(null? l) #f]
[(member (car l) valid) (verify-list (cdr l) valid)]
[else (car l)])))
(define verify-item
(lambda (item valid)
(λ (item valid)
(verify-list (list item) valid)))
;;;
@ -473,7 +473,7 @@
;; find-object : class (union string (object -> boolean)) -> object
(define (find-object obj-class b-desc)
(lambda ()
(λ ()
(cond
[(or (string? b-desc)
(procedure? b-desc))
@ -483,7 +483,7 @@
"could not find object: ~a, no active frame"
b-desc))]
[child-matches?
(lambda (child)
(λ (child)
(cond
[(string? b-desc)
(equal? (send child get-label) b-desc)]
@ -491,7 +491,7 @@
(b-desc child)]))]
[found
(let loop ([panel active-frame])
(ormap (lambda (child)
(ormap (λ (child)
(cond
[(and (is-a? child obj-class)
(child-matches? child))
@ -520,9 +520,9 @@
;;; CONTROL functions, to be specialized for individual controls
(define control-action
(lambda (error-tag event-sym find-ctrl update-control)
(λ (error-tag event-sym find-ctrl update-control)
(run-one
(lambda ()
(λ ()
(let ([event (make-object control-event% event-sym)]
[ctrl (find-ctrl)])
(cond
@ -557,7 +557,7 @@
'test:set-check-box!
'check-box
(find-object check-box% in-cb)
(lambda (cb) (send cb set-value state))))
(λ (cb) (send cb set-value state))))
;;
;; RADIO-BOX
@ -581,7 +581,7 @@
'test:set-radio-box!
'radio-box
(find-object radio-box% in-cb)
(lambda (rb)
(λ (rb)
(cond
[(string? state)
(let ([total (send rb get-number)])
@ -614,7 +614,7 @@
'test:set-check-box-state!
'radio-box
(find-object radio-box% (entry-matches state))
(lambda (rb)
(λ (rb)
(let ([total (send rb get-number)])
(let loop ([n total])
(cond
@ -631,7 +631,7 @@
;; entry-matches : string -> radio-box -> boolean
(define (entry-matches name)
(lambda (rb)
(λ (rb)
(let loop ([n (send rb get-number)])
(and (not (zero? n))
(or (equal? name (send rb get-item-label (- n 1)))
@ -646,7 +646,7 @@
'test:set-choice!
'choice
(find-object choice% in-choice)
(lambda (choice)
(λ (choice)
(cond
[(number? str) (send choice set-selection str)]
[(string? str) (send choice set-string-selection str)]
@ -692,10 +692,10 @@
[(not (list? modifier-list))
(error key-tag "expected a list as second argument, got: ~e" modifier-list)]
[(verify-list modifier-list legal-keystroke-modifiers)
=> (lambda (mod) (error key-tag "unknown key modifier: ~e" mod))]
=> (λ (mod) (error key-tag "unknown key modifier: ~e" mod))]
[else
(run-one
(lambda ()
(λ ()
(let ([window (get-focused-window)])
(cond
[(not window)
@ -734,7 +734,7 @@
;; WILL WANT TO ADD SET-POSITION WHEN THAT GETS IMPLEMENTED.
(define make-key-event
(lambda (key window modifier-list)
(λ (key window modifier-list)
(let ([event (make-object key-event%)])
(send event set-key-code key)
(send event set-time-stamp (time-stamp))
@ -742,7 +742,7 @@
event)))
(define set-key-modifiers
(lambda (event key modifier-list)
(λ (event key modifier-list)
(when (shifted? key) (send event set-shift-down #t))
(let loop ([l modifier-list])
(unless (null? l)
@ -765,7 +765,7 @@
#\! #\@ #\# #\$ #\% #\^ #\& #\* #\_ #\+
#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
#\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)])
(lambda (key)
(λ (key)
(memq shifted-keys shifted-keys))))
;;
@ -781,7 +781,7 @@
(define menu-tag 'test:menu-select)
(define menu-select
(lambda (menu-name . item-names)
(λ (menu-name . item-names)
(cond
[(not (string? menu-name))
(error menu-tag "expects string, given: ~e" menu-name)]
@ -789,7 +789,7 @@
(error menu-tag "expects strings, given: ~e" item-names)]
[else
(run-one
(lambda ()
(λ ()
(let* ([frame (get-active-frame)]
[item (get-menu-item frame (cons menu-name item-names))]
[evt (make-object control-event% 'menu)])
@ -797,7 +797,7 @@
(send item command evt))))])))
(define get-menu-item
(lambda (frame item-names)
(λ (frame item-names)
(cond
[(not frame)
(error menu-tag "no active frame")]
@ -863,18 +863,18 @@
[(button x y modifier-list)
(cond
[(verify-item button legal-mouse-buttons)
=> (lambda (button)
=> (λ (button)
(error mouse-tag "unknown mouse button: ~e" button))]
[(not (real? x))
(error mouse-tag "expected real, given: ~e" x)]
[(not (real? y))
(error mouse-tag "expected real, given: ~e" y)]
[(verify-list modifier-list legal-mouse-modifiers)
=> (lambda (mod)
=> (λ (mod)
(error mouse-tag "unknown mouse modifier: ~e" mod))]
[else
(run-one
(lambda ()
(λ ()
(let ([window (get-focused-window)])
(cond
[(not window)
@ -898,7 +898,7 @@
;; NEED TO MOVE THE CHECK FOR 'ON-EVENT TO HERE.
(define send-mouse-event
(lambda (window event)
(λ (window event)
(let loop ([l (ancestor-list window #t)])
(cond
[(null? l)
@ -913,7 +913,7 @@
;;
(define make-mouse-event
(lambda (type x y modifier-list)
(λ (type x y modifier-list)
(let ([event (make-object mouse-event% (mouse-type-const type))])
(when (and (pair? type) (not (eq? (cadr type) 'up)))
(set-mouse-modifiers event (list (car type))))
@ -924,7 +924,7 @@
event)))
(define set-mouse-modifiers
(lambda (event modifier-list)
(λ (event modifier-list)
(unless (null? modifier-list)
(let ([mod (car modifier-list)])
(cond
@ -943,7 +943,7 @@
(set-mouse-modifiers event (cdr modifier-list)))))
(define mouse-type-const
(lambda (type)
(λ (type)
(cond
[(symbol? type)
(cond
@ -976,7 +976,7 @@
[else (bad-mouse-type type)])))
(define bad-mouse-type
(lambda (type)
(λ (type)
(error mouse-tag "unknown mouse event type: ~e" type)))
;;
@ -989,13 +989,13 @@
(define new-window
(let ([tag 'test:new-window])
(lambda (new-window)
(λ (new-window)
(cond
[(not (is-a? new-window window<%>))
(error tag "new-window is not a window<%>")]
[else
(run-one
(lambda ()
(λ ()
(let
([old-window (get-focused-window)]
[leave (make-object mouse-event% 'leave)]

8
collects/mrlib/graph.ss
View File

@ -257,9 +257,9 @@
(inherit invalidate-bitmap-cache)
(define/private (invalidate-to-children/parents snip)
(when (is-a? snip graph-snip<%>)
(let* ([children (get-all-children snip)]
[parents (get-all-parents snip)]
[rects (eliminate-redundancies (get-rectangles snip (append children parents)))]
(let* ([parents-and-children (append (get-all-parents snip)
(get-all-children snip))]
[rects (eliminate-redundancies (get-rectangles snip parents-and-children))]
[union (union-rects rects)]
[invalidate-rect
(lambda (rect)
@ -300,7 +300,7 @@
((rect-top r1) . >= . (rect-top r2))
((rect-right r1) . <= . (rect-right r2))
((rect-bottom r1) . <= . (rect-bottom r2))))
;; get-rectangles : snip (listof snip) -> rect
;; computes the rectangles that need to be invalidated for connecting
(define/private (get-rectangles main-snip c/p-snips)