removed mz,mred,slideshow languages and made module language's initial REPL be scheme/base instead of mzscheme
svn: r9384
This commit is contained in:
Robby Findler
parent
a0f65ba33e
commit
f0f27e2e2c
|
|
@ -1385,46 +1385,15 @@
|
|||
(language-id id)
|
||||
(language-position position)
|
||||
(language-numbers numbers))))])
|
||||
(add-language
|
||||
(make-simple '(lib "lang/plt-mzscheme.ss")
|
||||
"plt:mz"
|
||||
(list (string-constant legacy-languages)
|
||||
(string-constant plt)
|
||||
(string-constant mzscheme-w/debug))
|
||||
(list -1000 -10 1)
|
||||
#f
|
||||
(string-constant mzscheme-one-line-summary)
|
||||
(λ (x) x)))
|
||||
(add-language
|
||||
(make-simple '(lib "lang/plt-mred.ss")
|
||||
"plt:mred"
|
||||
(list (string-constant legacy-languages)
|
||||
(string-constant plt)
|
||||
(string-constant mred-w/debug))
|
||||
(list -1000 -10 2)
|
||||
#t
|
||||
(string-constant mred-one-line-summary)
|
||||
(λ (x) x)))
|
||||
(add-language
|
||||
(make-simple '(lib "lang/plt-pretty-big.ss")
|
||||
"plt:pretty-big"
|
||||
(list (string-constant legacy-languages)
|
||||
(string-constant plt)
|
||||
(string-constant pretty-big-scheme))
|
||||
(list -1000 -10 3)
|
||||
(list -1000 3)
|
||||
#t
|
||||
(string-constant pretty-big-scheme-one-line-summary)
|
||||
(λ (x) x)))
|
||||
(add-language
|
||||
(make-simple '(lib "lang/plt-mzscheme.ss")
|
||||
"plt:expander"
|
||||
(list (string-constant legacy-languages)
|
||||
(string-constant plt)
|
||||
(string-constant expander))
|
||||
(list -1000 -10 4)
|
||||
#t
|
||||
(string-constant expander-one-line-summary)
|
||||
add-expand-to-front-end))
|
||||
(add-language
|
||||
(make-simple '(lib "r5rs/lang.ss")
|
||||
"plt:r5rs"
|
||||
|
|
|
|||
|
|
@ -223,7 +223,7 @@
|
|||
executable-filename))))))))
|
||||
|
||||
(super-new
|
||||
(module '(lib "plt-mred.ss" "lang"))
|
||||
(module 'scheme/base)
|
||||
(language-position (list "Module"))
|
||||
(language-numbers (list -32768)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,13 +2,6 @@
|
|||
|
||||
todo:
|
||||
|
||||
slideshow language:
|
||||
- handle ranges (just the first letter of an identifier),
|
||||
- show/hide menu in the wrong place
|
||||
- dock/undock the preview window
|
||||
- editing should make the annotations disappear (need to extend the program mixin)
|
||||
- move calls to draw-pict over to user's eventspace
|
||||
|
||||
pict snip :
|
||||
- snipclass for running snips outside of drscheme
|
||||
- need to toggle the picts back to scheme code when
|
||||
|
|
@ -58,10 +51,6 @@ pict snip :
|
|||
(define original-output-port (current-output-port))
|
||||
(define (oprintf . args) (apply fprintf original-output-port args))
|
||||
|
||||
(define sc-show-slideshow-panel (string-constant slideshow-show-slideshow-panel))
|
||||
(define sc-hide-slideshow-panel (string-constant slideshow-hide-slideshow-panel))
|
||||
(define sc-freeze-picts (string-constant slideshow-freeze-picts))
|
||||
(define sc-thaw-picts (string-constant slideshow-thaw-picts))
|
||||
(define sc-hide-picts (string-constant slideshow-hide-picts))
|
||||
(define sc-show-picts (string-constant slideshow-show-picts))
|
||||
(define sc-cannot-show-picts (string-constant slideshow-cannot-show-picts))
|
||||
|
|
@ -330,559 +319,13 @@ pict snip :
|
|||
(insert-snip
|
||||
(lambda () (new pict-snip%))))))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; drscheme extensions
|
||||
;;
|
||||
|
||||
(define-struct p (pict-drawer width height n))
|
||||
(define new-p
|
||||
(let ([c 0])
|
||||
(lambda (pd w h)
|
||||
(set! c (+ c 1))
|
||||
(make-p pd w h c))))
|
||||
|
||||
(define show-picts<%>
|
||||
(interface ()
|
||||
slideshow:register-pict))
|
||||
|
||||
(define show-picts-mixin
|
||||
(mixin (color:text<%> editor<%>) (show-picts<%>)
|
||||
(inherit get-canvas freeze-colorer)
|
||||
|
||||
;; all-picts-ht : hash-table[(cons text% number) -op> hash-table[pict -o> p]]
|
||||
;; the inner hashtables are really treated as sets, using the pict as
|
||||
;; the equality measure.
|
||||
(define all-picts-ht (make-hash-table 'equal))
|
||||
|
||||
(define frozen-colorers (make-hash-table))
|
||||
|
||||
(define mouse-loc #f)
|
||||
(define visible-picts #f)
|
||||
|
||||
(define/public (slideshow:clear-picts)
|
||||
(set! all-picts-ht (make-hash-table 'equal))
|
||||
(hash-table-for-each
|
||||
frozen-colorers
|
||||
(lambda (k v)
|
||||
(send k thaw-colorer)))
|
||||
(set! frozen-colorers (make-hash-table)))
|
||||
|
||||
(define/public (slideshow:register-pict text offset range pict pict-drawer width height)
|
||||
(hash-table-get frozen-colorers
|
||||
text
|
||||
(lambda ()
|
||||
(when (is-a? text color:text<%>)
|
||||
(let ([locked? (send text is-locked?)])
|
||||
(send text lock #f)
|
||||
(send text freeze-colorer)
|
||||
(send text lock locked?))
|
||||
(hash-table-put! frozen-colorers text #t))))
|
||||
(let ([locked? (send text is-locked?)])
|
||||
(send text lock #f)
|
||||
(send text change-style has-info-style offset (+ offset 1) #f)
|
||||
(send text lock locked?))
|
||||
(let* ([key (cons text offset)]
|
||||
[picts-ht
|
||||
(hash-table-get all-picts-ht
|
||||
key
|
||||
(lambda ()
|
||||
(let ([new-ht (make-hash-table)])
|
||||
(hash-table-put! all-picts-ht key new-ht)
|
||||
new-ht)))])
|
||||
;; store the new pict in the hash-table, unless it is already in there,
|
||||
;; in which case we leave the current one (so we don't get a new number)
|
||||
(hash-table-get
|
||||
picts-ht
|
||||
pict
|
||||
(lambda ()
|
||||
(hash-table-put!
|
||||
picts-ht
|
||||
pict
|
||||
(new-p pict-drawer width height))))))
|
||||
|
||||
(define/override (on-event evt)
|
||||
(cond
|
||||
[(send evt leaving?)
|
||||
(update-mouse #f #f)
|
||||
(super on-event evt)]
|
||||
[(or (send evt moving?)
|
||||
(send evt entering?))
|
||||
(let-values ([(pos text) (get-pos/text evt)])
|
||||
(update-mouse text pos))
|
||||
(super on-event evt)]
|
||||
[(send evt button-down? 'right)
|
||||
(let-values ([(pos text) (get-pos/text evt)])
|
||||
(if (and pos text)
|
||||
(unless (show-menu evt text pos)
|
||||
(super on-event evt))
|
||||
(super on-event evt)))]
|
||||
[else
|
||||
(super on-event evt)]))
|
||||
|
||||
;; show-menu : ... -> boolean
|
||||
;; result indicates if a menu was shown
|
||||
(define/private (show-menu evt text pos)
|
||||
(let ([frame (let ([canvas (get-canvas)])
|
||||
(and canvas
|
||||
(send canvas get-top-level-window)))])
|
||||
(and frame
|
||||
(let ([admin (send text get-admin)]
|
||||
[menu (new popup-menu%)]
|
||||
[show? #f])
|
||||
(let* ([frozen-mouse-picts-key (cons text pos)]
|
||||
[picts-ht (hash-table-get all-picts-ht frozen-mouse-picts-key (lambda () #f))])
|
||||
(when picts-ht
|
||||
(let ([picts (get-all-ps-from-ht picts-ht)])
|
||||
(set! show? #t)
|
||||
(new menu-item%
|
||||
(label sc-freeze-picts)
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda (x y)
|
||||
(send frame slideshow:set-permanent-picts picts)))))))
|
||||
(when (send frame slideshow:has-permanent-picts?)
|
||||
(new menu-item%
|
||||
(label sc-thaw-picts)
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda (x y)
|
||||
(send frame slideshow:set-permanent-picts #f))))
|
||||
(set! show? #t))
|
||||
(and show?
|
||||
(begin
|
||||
(send admin popup-menu
|
||||
menu
|
||||
(send evt get-x)
|
||||
(send evt get-y))
|
||||
#t))))))
|
||||
|
||||
(define/private (update-mouse text pos)
|
||||
(let ([new-mouse-loc (and text pos (cons text pos))])
|
||||
(unless (equal? new-mouse-loc mouse-loc)
|
||||
(set! mouse-loc new-mouse-loc)
|
||||
(let ([frame (let ([canvas (get-canvas)])
|
||||
(and canvas
|
||||
(send canvas get-top-level-window)))])
|
||||
(when frame
|
||||
(send frame slideshow:set-visible-picts
|
||||
(and pos
|
||||
text
|
||||
(let ([picts-ht
|
||||
(hash-table-get all-picts-ht new-mouse-loc (lambda () #f))])
|
||||
(and picts-ht
|
||||
(get-all-ps-from-ht picts-ht))))))))))
|
||||
|
||||
(define/private (get-all-ps-from-ht picts-ht)
|
||||
(let ([ps (hash-table-map picts-ht (lambda (k v) v))])
|
||||
(sort ps (lambda (x y) (<= (p-n x) (p-n y))))))
|
||||
|
||||
;; get-pos/text : event -> (values (union #f text%) (union number #f))
|
||||
;; returns two #fs to indicate the event doesn't correspond to
|
||||
;; a position in an editor, or returns the innermost text
|
||||
;; and position in that text where the event is.
|
||||
(define/private (get-pos/text event)
|
||||
(let ([event-x (send event get-x)]
|
||||
[event-y (send event get-y)]
|
||||
[on-it? (box #f)])
|
||||
(let loop ([editor this])
|
||||
(let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)])
|
||||
(cond
|
||||
[(is-a? editor text%)
|
||||
(let ([pos (send editor find-position x y #f on-it?)])
|
||||
(cond
|
||||
[(not (unbox on-it?)) (values #f #f)]
|
||||
[else
|
||||
(let ([snip (send editor find-snip pos 'after-or-none)])
|
||||
(if (and snip
|
||||
(is-a? snip editor-snip%))
|
||||
(loop (send snip get-editor))
|
||||
(values pos editor)))]))]
|
||||
[(is-a? editor pasteboard%)
|
||||
(let ([snip (send editor find-snip x y)])
|
||||
(if (and snip
|
||||
(is-a? snip editor-snip%))
|
||||
(loop (send snip get-editor))
|
||||
(values #f #f)))]
|
||||
[else (values #f #f)])))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define has-info-style (make-object style-delta%))
|
||||
(send has-info-style set-delta-background "black")
|
||||
(send has-info-style set-transparent-text-backing-off #t)
|
||||
(send has-info-style set-delta-foreground "hotpink")
|
||||
|
||||
(define tab-mixin
|
||||
(mixin (drscheme:rep:context<%> drscheme:unit:tab<%>) ()
|
||||
(inherit get-defs get-ints)
|
||||
(define/augment (clear-annotations)
|
||||
(send (get-defs) slideshow:clear-picts)
|
||||
(send (get-ints) slideshow:clear-picts)
|
||||
(inner (void) clear-annotations))
|
||||
(super-new)))
|
||||
|
||||
(define unit-frame-mixin
|
||||
(mixin (drscheme:unit:frame<%>) ()
|
||||
(inherit get-show-menu)
|
||||
|
||||
(define slideshow-parent-panel #f)
|
||||
(define everything-else-panel #f)
|
||||
(define slideshow-panel #f)
|
||||
(define slideshow-canvas #f)
|
||||
(define slideshow-panel-visible? #f)
|
||||
|
||||
(define permanent-picts #f)
|
||||
(define visible-picts #f)
|
||||
|
||||
(define/public (slideshow:set-visible-picts picts)
|
||||
(unless (equal? picts visible-picts)
|
||||
(set! visible-picts picts)
|
||||
(when slideshow-panel-visible?
|
||||
(draw-picts (send slideshow-canvas get-dc)))))
|
||||
|
||||
(define/public (slideshow:set-permanent-picts picts)
|
||||
(set! permanent-picts picts)
|
||||
(if picts
|
||||
(send slideshow-canvas
|
||||
init-auto-scrollbars
|
||||
(inexact->exact (floor (apply max (map p-width picts))))
|
||||
(inexact->exact (floor (apply + (map p-height picts))))
|
||||
0
|
||||
0)
|
||||
(send slideshow-canvas init-auto-scrollbars #f #f 0 0)))
|
||||
(define/public (slideshow:has-permanent-picts?) permanent-picts)
|
||||
|
||||
(define/override (make-root-area-container cls parent)
|
||||
(set! slideshow-parent-panel (super make-root-area-container slideshow-dragable% parent))
|
||||
(let ([root (make-object cls slideshow-parent-panel)])
|
||||
(set! everything-else-panel root)
|
||||
root))
|
||||
|
||||
(define/override (update-shown)
|
||||
(super update-shown)
|
||||
(if slideshow-panel-visible?
|
||||
(begin
|
||||
(send slideshow-parent-panel begin-container-sequence)
|
||||
(unless slideshow-panel (build-slideshow-panel))
|
||||
(when (is-a? view-menu-item menu-item%)
|
||||
(send view-menu-item set-label sc-hide-slideshow-panel))
|
||||
(send slideshow-parent-panel
|
||||
change-children
|
||||
(lambda (l)
|
||||
(list everything-else-panel slideshow-panel)))
|
||||
(send slideshow-parent-panel end-container-sequence))
|
||||
(begin
|
||||
(when (is-a? view-menu-item menu-item%)
|
||||
(send view-menu-item set-label sc-show-slideshow-panel))
|
||||
(send slideshow-parent-panel
|
||||
change-children
|
||||
(lambda (l)
|
||||
(list everything-else-panel))))))
|
||||
|
||||
(define/private (build-slideshow-panel)
|
||||
(let ([p (preferences:get 'plt:slideshow:panel-percentage)])
|
||||
;; must save the value of the pref before creating slideshow-panel
|
||||
;; so that the callback doesn't clobber it
|
||||
|
||||
(set! slideshow-panel (new vertical-panel% (parent slideshow-parent-panel)))
|
||||
(set! slideshow-canvas (new canvas%
|
||||
(style '(hscroll vscroll))
|
||||
(parent slideshow-panel)
|
||||
(paint-callback
|
||||
(lambda (x dc)
|
||||
(draw-picts dc)))))
|
||||
(send slideshow-parent-panel set-percentages (list p (- 1 p)))
|
||||
(preferences:set 'plt:slideshow:panel-percentage p)))
|
||||
|
||||
(define/private (draw-picts dc)
|
||||
(send dc clear)
|
||||
(let ([picts (or permanent-picts visible-picts)])
|
||||
(when picts
|
||||
(let loop ([picts picts]
|
||||
[y 0])
|
||||
(cond
|
||||
[(null? picts) (void)]
|
||||
[else (let ([pict (car picts)])
|
||||
((p-pict-drawer pict) dc 0 y)
|
||||
(loop (cdr picts)
|
||||
(+ y (p-height pict))))])))))
|
||||
|
||||
(define/override (add-show-menu-items show-menu)
|
||||
(super add-show-menu-items show-menu)
|
||||
(set! view-menu-item
|
||||
(new menu-item%
|
||||
(label sc-show-slideshow-panel)
|
||||
(parent (get-show-menu))
|
||||
(callback
|
||||
(lambda (x y)
|
||||
(set! slideshow-panel-visible? (not slideshow-panel-visible?))
|
||||
(update-shown))))))
|
||||
|
||||
(define view-menu-item #f)
|
||||
|
||||
(super-new)
|
||||
|
||||
(inherit get-insert-menu register-capability-menu-item)
|
||||
(add-special-menu-item (get-insert-menu) this)
|
||||
(register-capability-menu-item 'drscheme:special:slideshow-menu-item (get-insert-menu))))
|
||||
|
||||
(define slideshow-dragable%
|
||||
(class panel:horizontal-dragable%
|
||||
(inherit get-percentages)
|
||||
(define/augment (after-percentage-change)
|
||||
(let ([percentages (get-percentages)])
|
||||
(when (= 2 (length percentages))
|
||||
(preferences:set 'plt:slideshow:panel-percentage (car percentages))))
|
||||
(inner (void) after-percentage-change))
|
||||
(super-new)))
|
||||
|
||||
(define has-info-bkg-color (make-object color% "gray"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; preference defaults
|
||||
;;
|
||||
|
||||
;; size of the drscheme window.
|
||||
(preferences:set-default 'plt:slideshow:panel-percentage 3/4 (lambda (x) (and (number? x) (<= 0 x 1))))
|
||||
|
||||
(drscheme:language:register-capability 'drscheme:special:slideshow-menu-item (flat-contract boolean?) #t)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; communication from user thread to drscheme's repl
|
||||
;;
|
||||
|
||||
(define system-eventspace (current-eventspace))
|
||||
|
||||
;; send-over : any syntax -> void
|
||||
;; thread: (any) user's thread
|
||||
(define (send-over v stx)
|
||||
(let ([rep (drscheme:rep:current-rep)])
|
||||
(when rep
|
||||
(when (pict? v)
|
||||
(let ([pict-drawer (make-pict-drawer v)]
|
||||
[width (pict-width v)]
|
||||
[height (pict-height v)])
|
||||
(parameterize ([current-eventspace system-eventspace])
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(add-pict-drawer stx v pict-drawer width height)))))))))
|
||||
|
||||
;; add-pict-drawer : syntax pict-drawer number number -> void
|
||||
;; thread: system eventspace
|
||||
(define (add-pict-drawer stx pict pict-drawer width height)
|
||||
(let ([src (syntax-source stx)]
|
||||
[offset (syntax-position stx)]
|
||||
[span (syntax-span stx)])
|
||||
(when (and (is-a? src editor<%>)
|
||||
(number? offset)
|
||||
(number? span))
|
||||
(let ([top-most (let loop ([src src])
|
||||
(let ([admin (send src get-admin)])
|
||||
(cond
|
||||
[(not admin) #f]
|
||||
[(is-a? admin editor-snip-editor-admin<%>)
|
||||
(let* ([outer-editor-snip (send admin get-snip)]
|
||||
[es-admin (send outer-editor-snip get-admin)]
|
||||
[outer-editor (send es-admin get-editor)])
|
||||
(loop outer-editor))]
|
||||
[else src])))])
|
||||
(when (is-a? top-most show-picts<%>)
|
||||
(send top-most slideshow:register-pict src (- offset 1) span pict pict-drawer width height))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; slideshow lang
|
||||
;;
|
||||
|
||||
(define slideshow-mixin
|
||||
(mixin (drscheme:language:language<%>) ()
|
||||
(define/override (front-end/complete-program input settings)
|
||||
(let ([st (super front-end/complete-program input settings)])
|
||||
(lambda ()
|
||||
(let ([sv (st)])
|
||||
(cond
|
||||
[(syntax? sv) (rewrite-syntax sv)]
|
||||
[else sv])))))
|
||||
(define/override (front-end/interaction input settings)
|
||||
(let ([st (super front-end/interaction input settings)])
|
||||
(lambda ()
|
||||
(let ([sv (st)])
|
||||
(cond
|
||||
[(syntax? sv) (rewrite-syntax sv)]
|
||||
[else sv])))))
|
||||
(define/override (get-language-name) "Slideshow")
|
||||
(super-new (module '(lib "plt-mred.ss" "lang"))
|
||||
(language-position (list (string-constant experimental-languages)
|
||||
"Slideshow"))
|
||||
(language-numbers (list 1000 341)))))
|
||||
|
||||
(define (rewrite-syntax stx)
|
||||
(rewrite-top-level (expand stx)))
|
||||
|
||||
(define (rewrite-top-level stx)
|
||||
(syntax-case stx (module begin)
|
||||
[(module identifier name (#%plain-module-begin module-level-expr ...))
|
||||
(with-syntax ([(rewritten-module-level-expr ...) (map rewrite-module-level
|
||||
(syntax->list
|
||||
(syntax (module-level-expr ...))))])
|
||||
(syntax/cert stx (module identifier name (#%plain-module-begin rewritten-module-level-expr ...))))]
|
||||
[(begin top-level-expr ...)
|
||||
(with-syntax ([(rewritten-top-level-expr ...)
|
||||
(map rewrite-top-level (syntax->list (syntax (top-level-expr ...))))])
|
||||
(syntax/cert stx (begin rewritten-top-level-expr ...)))]
|
||||
[general-top-level-expr (rewrite-general-top-level stx)]))
|
||||
|
||||
(define (rewrite-module-level stx)
|
||||
(syntax-case stx (#%provide begin)
|
||||
[(#%provide provide-spec ...) stx]
|
||||
[(begin module-level-expr ...)
|
||||
(with-syntax ([(rewritten-module-level-expr ...)
|
||||
(map rewrite-module-level
|
||||
(syntax->list (syntax (module-level-expr ...))))])
|
||||
(syntax/cert stx (begin rewritten-module-level-expr ...)))]
|
||||
[general-top-level-expr (rewrite-general-top-level stx)]))
|
||||
|
||||
(define (rewrite-general-top-level stx)
|
||||
(syntax-case stx (define-values define-syntaxes define-values-for-syntax #%require)
|
||||
[(define-values (variable ...) expr)
|
||||
(with-syntax ([rewritten-expr (add-send-over (rewrite-expr (syntax expr))
|
||||
(syntax expr)
|
||||
(length (syntax->list (syntax (variable ...)))))])
|
||||
(syntax/cert stx (define-values (variable ...) rewritten-expr)))]
|
||||
[(define-syntaxes (variable ...) expr) stx]
|
||||
[(define-values-for-syntax (variable ...) expr) stx]
|
||||
[(#%require require-spec ...) stx]
|
||||
[expr (rewrite-expr stx)]))
|
||||
|
||||
(define (rewrite-expr stx)
|
||||
(syntax-case stx (lambda case-lambda if begin begin0 let-values letrec-values set! quote quote-syntax
|
||||
with-continuation-mark #%app #%top)
|
||||
[variable
|
||||
(identifier? (syntax variable))
|
||||
(add-send-over/var (syntax variable) stx)]
|
||||
[(lambda formals expr ...)
|
||||
(with-syntax ([(rewritten-expr ...)
|
||||
(map rewrite-expr (syntax->list (syntax (expr ...))))])
|
||||
(syntax/cert stx (lambda formals rewritten-expr ...)))]
|
||||
[(case-lambda (formals expr ...) ...)
|
||||
(with-syntax ([((rewritten-expr ...) ...)
|
||||
(map (lambda (exprs) (map rewrite-expr (syntax->list exprs)))
|
||||
(syntax->list (syntax ((expr ...) ...))))])
|
||||
(syntax/cert stx (case-lambda (formals rewritten-expr ...) ...)))]
|
||||
[(if expr1 expr2)
|
||||
(with-syntax ([rewritten-expr1 (add-send-over (rewrite-expr (syntax expr1)) (syntax expr1) 1)]
|
||||
[rewritten-expr2 (rewrite-expr (syntax expr2))])
|
||||
(syntax/cert stx (if rewritten-expr1 rewritten-expr2)))]
|
||||
[(if expr1 expr2 expr3)
|
||||
(with-syntax ([rewritten-expr1 (add-send-over (rewrite-expr (syntax expr1)) (syntax expr1) 1)]
|
||||
[rewritten-expr2 (rewrite-expr (syntax expr2))]
|
||||
[rewritten-expr3 (rewrite-expr (syntax expr3))])
|
||||
(syntax/cert stx (if rewritten-expr1 rewritten-expr2 rewritten-expr3)))]
|
||||
[(begin expr ... last-expr)
|
||||
(with-syntax ([(rewritten-expr ...) (map (lambda (x) (add-send-over (rewrite-expr x) x 1))
|
||||
(syntax->list (syntax (expr ...))))]
|
||||
[rewritten-last-expr (rewrite-expr (syntax last-expr))])
|
||||
(syntax/cert stx (begin rewritten-expr ... rewritten-last-expr)))]
|
||||
[(begin0 expr ...)
|
||||
(with-syntax ([(rewritten-expr ...) (map (lambda (x) (add-send-over (rewrite-expr x) x 1))
|
||||
(syntax->list (syntax (expr ...))))])
|
||||
(syntax/cert stx (begin0 rewritten-expr ...)))]
|
||||
[(let-values (((variable ...) v-expr) ...) expr ...)
|
||||
(with-syntax ([(rewritten-expr ...) (map rewrite-expr (syntax->list (syntax (expr ...))))]
|
||||
[(rewritten-v-expr ...) (map rewrite-expr (syntax->list (syntax (v-expr ...))))]
|
||||
[((send-over-vars ...) ...)
|
||||
(map (lambda (vars)
|
||||
(map (lambda (var) (add-send-over/var var var))
|
||||
(syntax->list vars)))
|
||||
(syntax->list (syntax ((variable ...) ...))))])
|
||||
(syntax/cert stx
|
||||
(let-values (((variable ...) rewritten-v-expr) ...)
|
||||
(begin (void) (begin (void) send-over-vars ...) ...)
|
||||
rewritten-expr ...)))]
|
||||
[(letrec-values (((variable ...) v-expr) ...) expr ...)
|
||||
(with-syntax ([(rewritten-expr ...) (map rewrite-expr (syntax->list (syntax (expr ...))))]
|
||||
[(rewritten-v-expr ...) (map rewrite-expr (syntax->list (syntax (v-expr ...))))]
|
||||
[((send-over-vars ...) ...)
|
||||
(map (lambda (vars)
|
||||
(map (lambda (var) (add-send-over/var var var))
|
||||
(syntax->list vars)))
|
||||
(syntax->list (syntax ((variable ...) ...))))])
|
||||
(syntax/cert stx
|
||||
(letrec-values (((variable ...) rewritten-v-expr) ...)
|
||||
(begin (void) (begin (void) send-over-vars ...) ...)
|
||||
rewritten-expr ...)))]
|
||||
[(set! variable expr)
|
||||
(with-syntax ([rewritten-expr (add-send-over (rewrite-expr (syntax expr)) (syntax expr) 1)])
|
||||
(syntax/cert stx (set! variable rewritten-expr)))]
|
||||
[(quote datum) stx]
|
||||
[(quote-syntax datum) stx]
|
||||
[(with-continuation-mark expr1 expr2 expr3)
|
||||
(with-syntax ([rewritten-expr1 (add-send-over (rewrite-expr (syntax expr1)) (syntax expr1) 1)]
|
||||
[rewritten-expr2 (add-send-over (rewrite-expr (syntax expr2)) (syntax expr2) 1)]
|
||||
[rewritten-expr3 (rewrite-expr (syntax expr3))])
|
||||
(syntax/cert stx (with-continuation-mark rewritten-expr1 rewritten-expr2 rewritten-expr3)))]
|
||||
[(#%app expr ...)
|
||||
(with-syntax ([(rewritten-expr ...) (map (lambda (x) (add-send-over (rewrite-expr x) x 1))
|
||||
(syntax->list (syntax (expr ...))))])
|
||||
(syntax/cert stx (#%app rewritten-expr ...)))]
|
||||
[(#%expression e)
|
||||
(with-syntax ([e (add-send-over (rewrite-expr #'x) #'x 1)])
|
||||
(syntax/cert stx (#%expression e)))]
|
||||
[(#%top . variable) stx]))
|
||||
|
||||
(define (add-send-over stx loc-stx values-expected)
|
||||
(if (object? (syntax-source loc-stx))
|
||||
(with-syntax ([send-over send-over]
|
||||
[stx stx]
|
||||
[loc (datum->syntax-object loc-stx 1 loc-stx)]
|
||||
[(vars ...) (build-vars values-expected)])
|
||||
(syntax
|
||||
(let-values ([(vars ...) stx])
|
||||
(send-over vars #'loc) ...
|
||||
(values vars ...))))
|
||||
stx))
|
||||
(define (add-send-over/var stx loc-stx)
|
||||
(if (object? (syntax-source loc-stx))
|
||||
(with-syntax ([send-over send-over]
|
||||
[stx stx]
|
||||
[loc (datum->syntax-object loc-stx 1 loc-stx)])
|
||||
(syntax
|
||||
(begin
|
||||
(send-over stx #'loc)
|
||||
stx)))
|
||||
stx))
|
||||
(define (build-vars n)
|
||||
(cond
|
||||
[(zero? n) #'()]
|
||||
[else (cons (datum->syntax-object #'here (string->symbol (format "x~a" n)))
|
||||
(build-vars (- n 1)))]))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; wire it up
|
||||
;;
|
||||
|
||||
(drscheme:get/extend:extend-interactions-text show-picts-mixin)
|
||||
(drscheme:get/extend:extend-definitions-text show-picts-mixin)
|
||||
(drscheme:get/extend:extend-unit-frame unit-frame-mixin)
|
||||
(drscheme:get/extend:extend-tab tab-mixin)
|
||||
|
||||
(define (phase1) (void))
|
||||
(define (phase2)
|
||||
(define slideshow-language%
|
||||
(slideshow-mixin
|
||||
((drscheme:language:get-default-mixin)
|
||||
(drscheme:language:module-based-language->language-mixin
|
||||
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
||||
drscheme:language:simple-module-based-language%)))))
|
||||
|
||||
(drscheme:language-configuration:add-language
|
||||
(new slideshow-language%)))
|
||||
(define (phase2) (void))
|
||||
|
||||
(define orig-namespace (current-namespace))
|
||||
|
||||
|
|
@ -921,7 +364,4 @@ pict snip :
|
|||
(define lib-pict-snipclass (make-object lib-pict-snipclass%))
|
||||
(send lib-pict-snipclass set-version 2)
|
||||
(send lib-pict-snipclass set-classname (format "~s" '(lib "pict-snipclass.ss" "slideshow")))
|
||||
(send (get-the-snip-class-list) add lib-pict-snipclass)
|
||||
|
||||
)))
|
||||
|
||||
(send (get-the-snip-class-list) add lib-pict-snipclass))))
|
||||
|
|
|
|||
|
|
@ -1239,10 +1239,6 @@ please adhere to these guidelines:
|
|||
(profjBoxes-insert-java-interactions "Indsæt Java-interaktioner")
|
||||
|
||||
;; Slideshow
|
||||
(slideshow-show-slideshow-panel "Vis diasshow-panel")
|
||||
(slideshow-hide-slideshow-panel "Skjul diasshow-panel")
|
||||
(slideshow-freeze-picts "Frys disse billeder")
|
||||
(slideshow-thaw-picts "Vis billeder under mus")
|
||||
(slideshow-hide-picts "Vis indlejrede kasser")
|
||||
(slideshow-show-picts "Vis billeder")
|
||||
(slideshow-cannot-show-picts "Kan ikke vise billeder; kør programmet for at cache størrelserne først")
|
||||
|
|
|
|||
|
|
@ -1359,10 +1359,6 @@ please adhere to these guidelines:
|
|||
(profjBoxes-insert-java-interactions "Insert Java Interactions")
|
||||
|
||||
;; Slideshow
|
||||
(slideshow-show-slideshow-panel "Show Slideshow Panel")
|
||||
(slideshow-hide-slideshow-panel "Hide Slideshow Panel")
|
||||
(slideshow-freeze-picts "Freeze These Picts")
|
||||
(slideshow-thaw-picts "Show Picts Under Mouse")
|
||||
(slideshow-hide-picts "Show Nested Boxes")
|
||||
(slideshow-show-picts "Show Picts")
|
||||
(slideshow-cannot-show-picts "Cannot show picts; run program to cache sizes first")
|
||||
|
|
|
|||
|
|
@ -1346,10 +1346,6 @@
|
|||
(profjBoxes-insert-java-interactions "Insérer des interactions Java")
|
||||
|
||||
;; Slideshow
|
||||
(slideshow-show-slideshow-panel "Montrer la sous-fenêtre Slideshow")
|
||||
(slideshow-hide-slideshow-panel "Cacher la sous-fenêtre Slideshow")
|
||||
(slideshow-freeze-picts "Geler ces images")
|
||||
(slideshow-thaw-picts "Montrer les images sous la souris")
|
||||
(slideshow-hide-picts "Montrer les boîtes nichées")
|
||||
(slideshow-show-picts "Montrer les images")
|
||||
(slideshow-cannot-show-picts "Il est impossible de montrer les images; exécutez d'abord le programme pour calculer les dimensions")
|
||||
|
|
|
|||
|
|
@ -1254,10 +1254,6 @@
|
|||
(profjBoxes-insert-java-interactions "Java-Interactionen einfügen")
|
||||
|
||||
;; Slideshow
|
||||
(slideshow-show-slideshow-panel "Slideshow-Panel zeigen")
|
||||
(slideshow-hide-slideshow-panel "Slideshow Panel")
|
||||
(slideshow-freeze-picts "Diese Picts einfrieren")
|
||||
(slideshow-thaw-picts "Picts unter der Maus zeigen")
|
||||
(slideshow-hide-picts "Geschachtelte Kästen anzeigen")
|
||||
(slideshow-show-picts "Picts anzeigen")
|
||||
(slideshow-cannot-show-picts "Kann die Picts nicht anzeigen; Sie müssen erst das Programm zum Cachen der Größen laufen lassen")
|
||||
|
|
|
|||
|
|
@ -1316,10 +1316,6 @@ please adhere to these guidelines:
|
|||
(profjBoxes-insert-java-interactions "Insert Java Interactions")
|
||||
|
||||
;; Slideshow
|
||||
(slideshow-show-slideshow-panel "スライドショー パネルを表示")
|
||||
(slideshow-hide-slideshow-panel "スライドショー パネルを非表示")
|
||||
(slideshow-freeze-picts "Freeze These Picts")
|
||||
(slideshow-thaw-picts "Show Picts Under Mouse")
|
||||
(slideshow-hide-picts "Show Nested Boxes")
|
||||
(slideshow-show-picts "Show Picts")
|
||||
(slideshow-cannot-show-picts "Cannot show picts; run program to cache sizes first")
|
||||
|
|
|
|||
|
|
@ -1176,10 +1176,6 @@ please adhere to these guidelines:
|
|||
(profjBoxes-insert-java-interactions "Insert Java Interactions")
|
||||
|
||||
;; Slideshow
|
||||
(slideshow-show-slideshow-panel "Mostrar Painel de Apresentação")
|
||||
(slideshow-hide-slideshow-panel "Esconder Painel de Apresentação")
|
||||
(slideshow-freeze-picts "Congelar estas Imagens")
|
||||
(slideshow-thaw-picts "Mostrar Imagens Debaixo do Ponteiro")
|
||||
(slideshow-hide-picts "Show Nested Boxes")
|
||||
(slideshow-show-picts "Mostrar Imagens")
|
||||
(slideshow-cannot-show-picts "Cannot show picts; run program to cache sizes first")
|
||||
|
|
|
|||
|
|
@ -1082,10 +1082,6 @@
|
|||
(profjBoxes-insert-java-interactions "Insertar Interacciones Java")
|
||||
|
||||
;; Slideshow
|
||||
(slideshow-show-slideshow-panel "Mostrar Panel de Slideshow")
|
||||
(slideshow-hide-slideshow-panel "Esconder Panel de Slideshow")
|
||||
(slideshow-freeze-picts "Congelar Estas Imágenes")
|
||||
(slideshow-thaw-picts "Mostrar las Imágenes debajo del Puntero")
|
||||
(slideshow-hide-picts "Mostrar Cajas Anidadas")
|
||||
(slideshow-show-picts "Mostrar Imágenes")
|
||||
(slideshow-cannot-show-picts "No puedo mostrar imágenes; ejecuta el programa para capturar primero sus tamaños")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user