Syncing up before class.
svn merge ^/trunk svn: r18188
This commit is contained in:
Stevie Strickland
commit
e9264b1fac
|
|
@ -35,7 +35,7 @@ Also added the timing code at the end.
|
|||
b-res
|
||||
line))))
|
||||
tests))
|
||||
|
||||
#;
|
||||
(define (empty-scene w h)
|
||||
(overlay
|
||||
(rectangle w h 'solid 'white)
|
||||
|
|
|
|||
|
|
@ -29,7 +29,8 @@
|
|||
|
||||
;; print-syntax-to-editor : syntax text controller<%> config number number
|
||||
;; -> display<%>
|
||||
(define (print-syntax-to-editor stx text controller config columns insertion-point)
|
||||
(define (print-syntax-to-editor stx text controller config columns
|
||||
[insertion-point (send text last-position)])
|
||||
(begin-with-definitions
|
||||
(define output-port (open-output-string/count-lines))
|
||||
(define range
|
||||
|
|
@ -37,6 +38,7 @@
|
|||
(send: controller controller<%> get-primary-partition)
|
||||
(length (send: config config<%> get-colors))
|
||||
(send: config config<%> get-suffix-option)
|
||||
(send config get-pretty-styles)
|
||||
columns))
|
||||
(define output-string (get-output-string output-port))
|
||||
(define output-length (sub1 (string-length output-string))) ;; skip final newline
|
||||
|
|
|
|||
|
|
@ -74,6 +74,14 @@
|
|||
(lambda (i e)
|
||||
(send config set-props-shown? #f)))
|
||||
|
||||
(define ((pretty-print-as sym) i e)
|
||||
(let ([stx (selected-syntax)])
|
||||
(when (identifier? stx)
|
||||
(send config set-pretty-styles
|
||||
(hash-set (send config get-pretty-styles)
|
||||
(syntax-e stx)
|
||||
sym)))))
|
||||
|
||||
(define/override (add-context-menu-items menu)
|
||||
(new menu-item% (label "Copy") (parent menu)
|
||||
(demand-callback
|
||||
|
|
@ -83,6 +91,27 @@
|
|||
(lambda (i e)
|
||||
(call-function "copy-syntax-as-text" i e))))
|
||||
(new separator-menu-item% (parent menu))
|
||||
(let ([pretty-menu
|
||||
(new menu%
|
||||
(label "Change layout")
|
||||
(parent menu)
|
||||
(demand-callback
|
||||
(lambda (i)
|
||||
(send i enable (and (identifier? (selected-syntax)) #t)))))])
|
||||
(for ([sym+desc '((and "like and")
|
||||
(begin "like begin (0 up)")
|
||||
(lambda "like lambda (1 up)")
|
||||
(do "like do (2 up)"))])
|
||||
(new menu-item%
|
||||
(label (format "Format identifier ~a" (cadr sym+desc)))
|
||||
(parent pretty-menu)
|
||||
(demand-callback
|
||||
(lambda (i)
|
||||
(let ([stx (selected-syntax)])
|
||||
(send i set-label
|
||||
(format "Format ~s ~a" (syntax-e stx) (cadr sym+desc))))))
|
||||
(callback
|
||||
(pretty-print-as (car sym+desc))))))
|
||||
(new menu-item%
|
||||
(label "Clear selection")
|
||||
(parent menu)
|
||||
|
|
|
|||
|
|
@ -24,6 +24,10 @@
|
|||
;; suffix-option : SuffixOption
|
||||
(define-notify suffix-option (new notify-box% (value 'over-limit)))
|
||||
|
||||
;; pretty-styles : ImmutableHash[symbol -> symbol]
|
||||
(define-notify pretty-styles
|
||||
(new notify-box% (value (make-immutable-hasheq null))))
|
||||
|
||||
;; syntax-font-size : number/#f
|
||||
;; When non-false, overrides the default font size
|
||||
(define-notify syntax-font-size (new notify-box% (value #f)))
|
||||
|
|
|
|||
|
|
@ -171,8 +171,8 @@
|
|||
(list expr))))))
|
||||
|
||||
(define special-expression-keywords
|
||||
'(quote quasiquote unquote unquote-splicing syntax))
|
||||
;; FIXME: quasisyntax unsyntax unsyntax-splicing
|
||||
'(quote quasiquote unquote unquote-splicing syntax
|
||||
quasisyntax unsyntax unsyntax-splicing))
|
||||
|
||||
(define (suffix sym n)
|
||||
(string->symbol (format "~a:~a" sym n)))
|
||||
|
|
|
|||
|
|
@ -9,9 +9,9 @@
|
|||
|
||||
;; FIXME: Need to disable printing of structs with custom-write property
|
||||
|
||||
;; pretty-print-syntax : syntax port partition number SuffixOption number
|
||||
;; pretty-print-syntax : syntax port partition number SuffixOption hasheq number
|
||||
;; -> range%
|
||||
(define (pretty-print-syntax stx port primary-partition colors suffix-option columns)
|
||||
(define (pretty-print-syntax stx port primary-partition colors suffix-option styles columns)
|
||||
(define range-builder (new range-builder%))
|
||||
(define-values (datum ht:flat=>stx ht:stx=>flat)
|
||||
(syntax->datum/tables stx primary-partition colors suffix-option))
|
||||
|
|
@ -45,7 +45,7 @@
|
|||
[pretty-print-size-hook pp-size-hook]
|
||||
[pretty-print-print-hook pp-print-hook]
|
||||
[pretty-print-remap-stylable pp-remap-stylable]
|
||||
[pretty-print-current-style-table (pp-better-style-table)]
|
||||
[pretty-print-current-style-table (pp-better-style-table styles)]
|
||||
[pretty-print-columns columns])
|
||||
(pretty-print/defaults datum port)
|
||||
(new range%
|
||||
|
|
@ -72,8 +72,21 @@
|
|||
(define (pp-remap-stylable obj)
|
||||
(and (id-syntax-dummy? obj) (id-syntax-dummy-remap obj)))
|
||||
|
||||
(define (pp-better-style-table)
|
||||
(basic-style-list)
|
||||
(define (pp-better-style-table styles)
|
||||
(define style-list (for/list ([(k v) (in-hash styles)]) (cons k v)))
|
||||
(pretty-print-extend-style-table
|
||||
(basic-style-list)
|
||||
(map car style-list)
|
||||
(map cdr style-list)))
|
||||
|
||||
(define (basic-style-list)
|
||||
(pretty-print-extend-style-table
|
||||
(pretty-print-current-style-table)
|
||||
(map car basic-styles)
|
||||
(map cdr basic-styles)))
|
||||
(define basic-styles
|
||||
'((define-values . define)
|
||||
(define-syntaxes . define-syntax))
|
||||
#|
|
||||
;; Messes up formatting too much :(
|
||||
(let* ([pref (pref:tabify)]
|
||||
|
|
@ -88,15 +101,6 @@
|
|||
(map cdr style-list))))
|
||||
|#)
|
||||
|
||||
(define (basic-style-list)
|
||||
(pretty-print-extend-style-table
|
||||
(pretty-print-current-style-table)
|
||||
(map car basic-styles)
|
||||
(map cdr basic-styles)))
|
||||
(define basic-styles
|
||||
'((define-values . define)
|
||||
(define-syntaxes . define-syntax)))
|
||||
|
||||
(define-local-member-name range:get-ranges)
|
||||
|
||||
;; range-builder%
|
||||
|
|
|
|||
|
|
@ -2,76 +2,17 @@
|
|||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:])
|
||||
scheme/match
|
||||
scheme/list
|
||||
mzlib/string
|
||||
mred
|
||||
framework
|
||||
unstable/gui/notify
|
||||
"interfaces.ss"
|
||||
"display.ss"
|
||||
"controller.ss"
|
||||
"keymap.ss"
|
||||
"properties.ss"
|
||||
"partition.ss"
|
||||
"prefs.ss")
|
||||
"prefs.ss"
|
||||
(except-in "snip.ss"
|
||||
snip-class))
|
||||
|
||||
(provide syntax-snip%
|
||||
syntax-value-snip%)
|
||||
|
||||
(define syntax-snip-config%
|
||||
(class prefs-base%
|
||||
(define-notify props-shown? (new notify-box% (value #f)))
|
||||
(super-new)))
|
||||
|
||||
;; syntax-value-snip%
|
||||
(define syntax-value-snip%
|
||||
(class* editor-snip% (readable-snip<%>)
|
||||
(init-field ((stx syntax)))
|
||||
(init-field (controller (new controller%)))
|
||||
(init-field (config (new syntax-snip-config%)))
|
||||
|
||||
(inherit set-margin
|
||||
set-inset)
|
||||
|
||||
(define text (new text:standard-style-list%))
|
||||
(super-new (editor text) (with-border? #f))
|
||||
|
||||
(set-margin 0 0 0 0)
|
||||
;;(set-inset 2 2 2 2)
|
||||
;;(set-margin 2 2 2 2)
|
||||
(set-inset 0 0 0 0)
|
||||
|
||||
(send text begin-edit-sequence)
|
||||
(send text change-style (make-object style-delta% 'change-alignment 'top))
|
||||
(define display
|
||||
(print-syntax-to-editor stx text controller config))
|
||||
(send text lock #t)
|
||||
(send text end-edit-sequence)
|
||||
(send text hide-caret #t)
|
||||
|
||||
(setup-keymap text)
|
||||
|
||||
(define/public (setup-keymap text)
|
||||
(new syntax-keymap%
|
||||
(controller controller)
|
||||
(config config)
|
||||
(editor text)))
|
||||
|
||||
;; snip% Methods
|
||||
(define/override (copy)
|
||||
(new syntax-value-snip%
|
||||
(config config)
|
||||
(controller controller)
|
||||
(syntax stx)))
|
||||
|
||||
;; read-special : any number/#f number/#f number/#f -> syntax
|
||||
;; Produces 3D syntax to preserve eq-ness of syntax
|
||||
;; #'#'stx would be lose identity when wrapped
|
||||
(define/public (read-special src line col pos)
|
||||
(with-syntax ([p (lambda () stx)])
|
||||
#'(p)))
|
||||
))
|
||||
(provide decorated-syntax-snip%
|
||||
snip-class)
|
||||
|
||||
(define top-aligned
|
||||
(make-object style-delta% 'change-alignment 'top))
|
||||
|
|
@ -155,18 +96,18 @@
|
|||
(refresh-contents)
|
||||
))
|
||||
|
||||
;; syntax-snip%
|
||||
(define syntax-snip%
|
||||
;; decorated-syntax-snip%
|
||||
(define decorated-syntax-snip%
|
||||
(class* clicky-snip% (readable-snip<%>)
|
||||
(init-field ((stx syntax)))
|
||||
(init-field [controller (new controller%)])
|
||||
(init-field [config (new syntax-snip-config%)])
|
||||
(init-field [config (new syntax-prefs%)])
|
||||
|
||||
(inherit set-snipclass
|
||||
refresh-contents)
|
||||
|
||||
(define the-syntax-snip
|
||||
(new syntax-value-snip%
|
||||
(new syntax-snip%
|
||||
(syntax stx)
|
||||
(controller controller)
|
||||
(config config)))
|
||||
|
|
@ -193,7 +134,10 @@
|
|||
|
||||
;; Snip methods
|
||||
(define/override (copy)
|
||||
(new syntax-snip% (syntax stx)))
|
||||
(new decorated-syntax-snip%
|
||||
(syntax stx)
|
||||
(controller controller)
|
||||
(config config)))
|
||||
(define/override (write stream)
|
||||
(send stream put
|
||||
(string->bytes/utf-8
|
||||
|
|
@ -251,105 +195,19 @@
|
|||
(make-object image-snip%
|
||||
(build-path (collection-path "icons") "syncheck.png")))
|
||||
|
||||
;; marshall-syntax : syntax -> printable
|
||||
(define (marshall-syntax stx)
|
||||
(unless (syntax? stx)
|
||||
(error 'marshall-syntax "not syntax: ~s\n" stx))
|
||||
`(syntax
|
||||
(source ,(marshall-object (syntax-source stx)))
|
||||
(source-module ,(marshall-object (syntax-source-module stx)))
|
||||
(position ,(syntax-position stx))
|
||||
(line ,(syntax-line stx))
|
||||
(column ,(syntax-column stx))
|
||||
(span ,(syntax-span stx))
|
||||
(original? ,(syntax-original? stx))
|
||||
(properties
|
||||
,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x))))
|
||||
(syntax-property-symbol-keys stx)))
|
||||
(contents
|
||||
,(marshall-object (syntax-e stx)))))
|
||||
|
||||
;; marshall-object : any -> printable
|
||||
;; really only intended for use with marshall-syntax
|
||||
(define (marshall-object obj)
|
||||
(cond
|
||||
[(syntax? obj) (marshall-syntax obj)]
|
||||
[(pair? obj)
|
||||
`(pair ,(cons (marshall-object (car obj))
|
||||
(marshall-object (cdr obj))))]
|
||||
[(or (symbol? obj)
|
||||
(char? obj)
|
||||
(number? obj)
|
||||
(string? obj)
|
||||
(boolean? obj)
|
||||
(null? obj))
|
||||
`(other ,obj)]
|
||||
[else (string->symbol (format "unknown-object: ~s" obj))]))
|
||||
;; SNIPCLASS
|
||||
|
||||
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
|
||||
(define syntax-snipclass%
|
||||
(define decorated-syntax-snipclass%
|
||||
(class snip-class%
|
||||
(define/override (read stream)
|
||||
(make-object syntax-snip%
|
||||
(unmarshall-syntax (read-from-string (send stream get-bytes)))))
|
||||
(super-instantiate ())))
|
||||
(new decorated-syntax-snip%
|
||||
(syntax (unmarshall-syntax
|
||||
(read-from-string (send stream get-bytes))))))
|
||||
(super-new)))
|
||||
|
||||
(define snip-class (make-object syntax-snipclass%))
|
||||
(define snip-class (make-object decorated-syntax-snipclass%))
|
||||
(send snip-class set-version 2)
|
||||
(send snip-class set-classname
|
||||
(format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser")))
|
||||
(send (get-the-snip-class-list) add snip-class)
|
||||
|
||||
(define (unmarshall-syntax stx)
|
||||
(match stx
|
||||
[`(syntax
|
||||
(source ,src)
|
||||
(source-module ,source-module) ;; marshalling
|
||||
(position ,pos)
|
||||
(line ,line)
|
||||
(column ,col)
|
||||
(span ,span)
|
||||
(original? ,original?)
|
||||
(properties . ,properties)
|
||||
(contents ,contents))
|
||||
(foldl
|
||||
add-properties
|
||||
(datum->syntax
|
||||
#'here ;; ack
|
||||
(unmarshall-object contents)
|
||||
(list (unmarshall-object src)
|
||||
line
|
||||
col
|
||||
pos
|
||||
span))
|
||||
properties)]
|
||||
[else #'unknown-syntax-object]))
|
||||
|
||||
;; add-properties : syntax any -> syntax
|
||||
(define (add-properties prop-spec stx)
|
||||
(match prop-spec
|
||||
[`(,(and sym (? symbol?))
|
||||
,prop)
|
||||
(syntax-property stx sym (unmarshall-object prop))]
|
||||
[else stx]))
|
||||
|
||||
(define (unmarshall-object obj)
|
||||
(let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))])
|
||||
(if (and (pair? obj)
|
||||
(symbol? (car obj)))
|
||||
(case (car obj)
|
||||
[(pair)
|
||||
(if (pair? (cdr obj))
|
||||
(let ([raw-obj (cadr obj)])
|
||||
(if (pair? raw-obj)
|
||||
(cons (unmarshall-object (car raw-obj))
|
||||
(unmarshall-object (cdr raw-obj)))
|
||||
(unknown)))
|
||||
(unknown))]
|
||||
[(other)
|
||||
(if (pair? (cdr obj))
|
||||
(cadr obj)
|
||||
(unknown))]
|
||||
[(syntax) (unmarshall-syntax obj)]
|
||||
[else (unknown)])
|
||||
(unknown))))
|
||||
(format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.ss")))
|
||||
181
collects/macro-debugger/syntax-browser/snip.ss
Normal file
181
collects/macro-debugger/syntax-browser/snip.ss
Normal file
|
|
@ -0,0 +1,181 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:])
|
||||
scheme/match
|
||||
mzlib/string
|
||||
mred
|
||||
framework
|
||||
"interfaces.ss"
|
||||
"display.ss"
|
||||
"controller.ss"
|
||||
"keymap.ss"
|
||||
"prefs.ss")
|
||||
|
||||
(provide syntax-snip%
|
||||
marshall-syntax
|
||||
unmarshall-syntax
|
||||
snip-class)
|
||||
|
||||
;; syntax-snip%
|
||||
(define syntax-snip%
|
||||
(class* editor-snip% (readable-snip<%>)
|
||||
(init-field ((stx syntax)))
|
||||
(init-field (controller (new controller%)))
|
||||
(init-field (config (new syntax-prefs/readonly%)))
|
||||
(init-field (columns 40))
|
||||
|
||||
(inherit set-margin
|
||||
set-inset
|
||||
set-snipclass)
|
||||
|
||||
(define text (new text:standard-style-list%))
|
||||
(super-new (editor text) (with-border? #f))
|
||||
|
||||
(set-margin 0 0 0 0)
|
||||
;;(set-inset 2 2 2 2)
|
||||
;;(set-margin 2 2 2 2)
|
||||
(set-inset 0 0 0 0)
|
||||
|
||||
(send text begin-edit-sequence)
|
||||
(send text change-style (make-object style-delta% 'change-alignment 'top))
|
||||
(define display
|
||||
(print-syntax-to-editor stx text controller config columns))
|
||||
(send text lock #t)
|
||||
(send text end-edit-sequence)
|
||||
(send text hide-caret #t)
|
||||
|
||||
(setup-keymap text)
|
||||
|
||||
(define/public (setup-keymap text)
|
||||
(new syntax-keymap%
|
||||
(controller controller)
|
||||
(config config)
|
||||
(editor text)))
|
||||
|
||||
;; snip% Methods
|
||||
(define/override (copy)
|
||||
(new syntax-snip%
|
||||
(config config)
|
||||
(controller controller)
|
||||
(syntax stx)))
|
||||
|
||||
;; read-special : any number/#f number/#f number/#f -> syntax
|
||||
;; Produces 3D syntax to preserve eq-ness of syntax
|
||||
;; #'#'stx would be lose identity when wrapped
|
||||
(define/public (read-special src line col pos)
|
||||
(with-syntax ([p (lambda () stx)])
|
||||
#'(p)))
|
||||
|
||||
(define/override (write stream)
|
||||
(send stream put
|
||||
(string->bytes/utf-8
|
||||
(format "~s" (marshall-syntax stx)))))
|
||||
|
||||
(set-snipclass snip-class)))
|
||||
|
||||
;; Marshalling stuff
|
||||
|
||||
;; marshall-syntax : syntax -> printable
|
||||
(define (marshall-syntax stx)
|
||||
(unless (syntax? stx)
|
||||
(error 'marshall-syntax "not syntax: ~s\n" stx))
|
||||
`(syntax
|
||||
(source ,(marshall-object (syntax-source stx)))
|
||||
(source-module ,(marshall-object (syntax-source-module stx)))
|
||||
(position ,(syntax-position stx))
|
||||
(line ,(syntax-line stx))
|
||||
(column ,(syntax-column stx))
|
||||
(span ,(syntax-span stx))
|
||||
(original? ,(syntax-original? stx))
|
||||
(properties
|
||||
,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x))))
|
||||
(syntax-property-symbol-keys stx)))
|
||||
(contents
|
||||
,(marshall-object (syntax-e stx)))))
|
||||
|
||||
;; marshall-object : any -> printable
|
||||
;; really only intended for use with marshall-syntax
|
||||
(define (marshall-object obj)
|
||||
(cond
|
||||
[(syntax? obj) (marshall-syntax obj)]
|
||||
[(pair? obj)
|
||||
`(pair ,(cons (marshall-object (car obj))
|
||||
(marshall-object (cdr obj))))]
|
||||
[(or (symbol? obj)
|
||||
(char? obj)
|
||||
(number? obj)
|
||||
(string? obj)
|
||||
(boolean? obj)
|
||||
(null? obj))
|
||||
`(other ,obj)]
|
||||
[else (string->symbol (format "unknown-object: ~s" obj))]))
|
||||
|
||||
(define (unmarshall-syntax stx)
|
||||
(match stx
|
||||
[`(syntax
|
||||
(source ,src)
|
||||
(source-module ,source-module) ;; marshalling
|
||||
(position ,pos)
|
||||
(line ,line)
|
||||
(column ,col)
|
||||
(span ,span)
|
||||
(original? ,original?)
|
||||
(properties . ,properties)
|
||||
(contents ,contents))
|
||||
(foldl
|
||||
add-properties
|
||||
(datum->syntax
|
||||
#'here ;; ack
|
||||
(unmarshall-object contents)
|
||||
(list (unmarshall-object src)
|
||||
line
|
||||
col
|
||||
pos
|
||||
span))
|
||||
properties)]
|
||||
[else #'unknown-syntax-object]))
|
||||
|
||||
;; add-properties : syntax any -> syntax
|
||||
(define (add-properties prop-spec stx)
|
||||
(match prop-spec
|
||||
[`(,(and sym (? symbol?))
|
||||
,prop)
|
||||
(syntax-property stx sym (unmarshall-object prop))]
|
||||
[else stx]))
|
||||
|
||||
(define (unmarshall-object obj)
|
||||
(let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))])
|
||||
(if (and (pair? obj)
|
||||
(symbol? (car obj)))
|
||||
(case (car obj)
|
||||
[(pair)
|
||||
(if (pair? (cdr obj))
|
||||
(let ([raw-obj (cadr obj)])
|
||||
(if (pair? raw-obj)
|
||||
(cons (unmarshall-object (car raw-obj))
|
||||
(unmarshall-object (cdr raw-obj)))
|
||||
(unknown)))
|
||||
(unknown))]
|
||||
[(other)
|
||||
(if (pair? (cdr obj))
|
||||
(cadr obj)
|
||||
(unknown))]
|
||||
[(syntax) (unmarshall-syntax obj)]
|
||||
[else (unknown)])
|
||||
(unknown))))
|
||||
|
||||
;; SNIPCLASS
|
||||
|
||||
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
|
||||
(define syntax-snipclass%
|
||||
(class snip-class%
|
||||
(define/override (read stream)
|
||||
(make-object syntax-snip%
|
||||
(unmarshall-syntax (read-from-string (send stream get-bytes)))))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define snip-class (new syntax-snipclass%))
|
||||
(send snip-class set-version 2)
|
||||
(send snip-class set-classname
|
||||
(format "~s" '(lib "macro-debugger/syntax-browser/snip.ss")))
|
||||
|
|
@ -168,6 +168,8 @@
|
|||
(lambda (_) (refresh/re-reduce)))
|
||||
(listen-extra-navigation?
|
||||
(lambda (show?) (show-extra-navigation show?))))
|
||||
(send config listen-pretty-styles
|
||||
(lambda (_) (update/preserve-view)))
|
||||
|
||||
(define nav:up
|
||||
(new button% (label "Previous term") (parent navigator)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
#lang scheme/base (provide stamp) (define stamp "18feb2010")
|
||||
#lang scheme/base (provide stamp) (define stamp "19feb2010")
|
||||
|
|
|
|||
|
|
@ -1188,7 +1188,8 @@
|
|||
(and (pretty-print-abbreviate-read-macros)
|
||||
(let ((head (do-remap (car l))) (tail (cdr l)))
|
||||
(case head
|
||||
((quote quasiquote unquote unquote-splicing syntax unsyntax unsyntax-splicing)
|
||||
((quote quasiquote unquote unquote-splicing syntax
|
||||
quasisyntax unsyntax unsyntax-splicing)
|
||||
(length1? tail))
|
||||
(else #f)))))
|
||||
|
||||
|
|
@ -1203,6 +1204,7 @@
|
|||
((unquote) ",")
|
||||
((unquote-splicing) ",@")
|
||||
((syntax) "#'")
|
||||
((quasisyntax) "#`")
|
||||
((unsyntax) "#,")
|
||||
((unsyntax-splicing) "#,@"))))
|
||||
|
||||
|
|
|
|||
|
|
@ -260,9 +260,9 @@ Propagates the request to any snip with the editor-local focus.
|
|||
|
||||
}}
|
||||
|
||||
@defmethod[(can-do-edit-operation? [op (one-of/c 'undo 'redo 'clear 'cut 'copy 'paste
|
||||
'kill 'select-all 'insert-text-box
|
||||
'insert-pasteboard-box 'insert-image)]
|
||||
@defmethod[(can-do-edit-operation? [op (or/c 'undo 'redo 'clear 'cut 'copy 'paste
|
||||
'kill 'select-all 'insert-text-box
|
||||
'insert-pasteboard-box 'insert-image)]
|
||||
[recursive? any/c #t])
|
||||
boolean?]{
|
||||
@methspec{
|
||||
|
|
@ -282,8 +282,8 @@ locked, etc.
|
|||
|
||||
@defmethod[#:mode pubment
|
||||
(can-load-file? [filename path?]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr)])
|
||||
[format (or/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr)])
|
||||
boolean?]{
|
||||
@methspec{
|
||||
|
||||
|
|
@ -308,8 +308,8 @@ Returns @scheme[#t].
|
|||
|
||||
@defmethod[#:mode pubment
|
||||
(can-save-file? [filename path?]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr)])
|
||||
[format (or/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr)])
|
||||
boolean?]{
|
||||
@methspec{
|
||||
|
||||
|
|
@ -462,9 +462,9 @@ Returns the name of a style to be used for newly inserted text,
|
|||
See @xmethod[text% do-copy] or @xmethod[pasteboard% do-copy].}
|
||||
|
||||
|
||||
@defmethod[(do-edit-operation [op (one-of/c 'undo 'redo 'clear 'cut 'copy 'paste
|
||||
'kill 'select-all 'insert-text-box
|
||||
'insert-pasteboard-box 'insert-image)]
|
||||
@defmethod[(do-edit-operation [op (or/c 'undo 'redo 'clear 'cut 'copy 'paste
|
||||
'kill 'select-all 'insert-text-box
|
||||
'insert-pasteboard-box 'insert-image)]
|
||||
[recursive? any/c #t]
|
||||
[time (and/c exact? integer?) 0])
|
||||
void?]{
|
||||
|
|
@ -700,7 +700,7 @@ See also @method[editor<%> set-caret-owner].
|
|||
|
||||
|
||||
@defmethod[(get-inactive-caret-threshold)
|
||||
(one-of/c 'no-caret 'show-inactive-caret 'show-caret)]{
|
||||
(or/c 'no-caret 'show-inactive-caret 'show-caret)]{
|
||||
|
||||
Returns the threshold for painting an inactive selection. This
|
||||
threshold is compared with the @scheme[draw-caret] argument to
|
||||
|
|
@ -928,7 +928,7 @@ Inserts data into the editor. A snip cannot be inserted into multiple
|
|||
}
|
||||
|
||||
|
||||
@defmethod[(insert-box [type (one-of/c 'text 'pasteboard) 'text])
|
||||
@defmethod[(insert-box [type (or/c 'text 'pasteboard) 'text])
|
||||
void?]{
|
||||
|
||||
Inserts a box (a sub-editor) into the editor by calling
|
||||
|
|
@ -941,13 +941,13 @@ inserts the resulting snip into the editor.
|
|||
|
||||
|
||||
@defmethod*[([(insert-file [filename path-string?]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'guess]
|
||||
[format (or/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'guess]
|
||||
[show-errors? any/c #t])
|
||||
boolean?]
|
||||
[(insert-file [port input-port?]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'guess]
|
||||
[format (or/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'guess]
|
||||
[show-errors? any/c #t])
|
||||
boolean?])]{
|
||||
|
||||
|
|
@ -967,7 +967,7 @@ The @scheme[show-errors?] argument is no longer used.
|
|||
|
||||
|
||||
@defmethod[(insert-image [filename (or/c path-string? #f) #f]
|
||||
[type (one-of/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict) 'unknown]
|
||||
[type (or/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict) 'unknown]
|
||||
[relative-path? any/c #f]
|
||||
[inline? any/c #t])
|
||||
void?]{
|
||||
|
|
@ -989,10 +989,10 @@ calling
|
|||
}
|
||||
|
||||
@defmethod[(insert-port [port input-port?]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'guess]
|
||||
[format (or/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'guess]
|
||||
[replace-styles? any/c #t])
|
||||
(one-of/c 'standard 'text 'text-force-cr)]{
|
||||
(or/c 'standard 'text 'text-force-cr)]{
|
||||
|
||||
Use @method[editor<%> insert-file], instead.
|
||||
|
||||
|
|
@ -1081,8 +1081,8 @@ See also @method[editor<%> cut].
|
|||
|
||||
|
||||
@defmethod[(load-file [filename (or/c path-string? #f) #f]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'guess]
|
||||
[format (or/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'guess]
|
||||
[show-errors? any/c #t])
|
||||
boolean?]{
|
||||
|
||||
|
|
@ -1442,8 +1442,8 @@ Either passes this event on to a caret-owning snip, selects a new
|
|||
|
||||
@defmethod[#:mode pubment
|
||||
(on-load-file [filename path?]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr)])
|
||||
[format (or/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr)])
|
||||
void?]{
|
||||
@methspec{
|
||||
|
||||
|
|
@ -1503,7 +1503,7 @@ Either lets the keymap handle the event or calls
|
|||
}}
|
||||
|
||||
|
||||
@defmethod[(on-new-box [type (one-of/c 'text 'pasteboard)])
|
||||
@defmethod[(on-new-box [type (or/c 'text 'pasteboard)])
|
||||
(is-a?/c snip%)]{
|
||||
@methspec{
|
||||
|
||||
|
|
@ -1524,7 +1524,7 @@ Creates a @scheme[editor-snip%] with either a sub-editor from
|
|||
|
||||
|
||||
@defmethod[(on-new-image-snip [filename path?]
|
||||
[kind (one-of/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict)]
|
||||
[kind (or/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict)]
|
||||
[relative-path? any/c]
|
||||
[inline? any/c])
|
||||
(is-a?/c image-snip%)]{
|
||||
|
|
@ -1552,7 +1552,7 @@ Returns @scheme[(make-object image-snip% filename kind relative-path? inline?)].
|
|||
[bottom real?]
|
||||
[dx real?]
|
||||
[dy real?]
|
||||
[draw-caret (one-of/c 'no-caret 'show-inactive-caret 'show-caret)])
|
||||
[draw-caret (or/c 'no-caret 'show-inactive-caret 'show-caret)])
|
||||
void?]{
|
||||
@methspec{
|
||||
|
||||
|
|
@ -1602,8 +1602,8 @@ Does nothing.
|
|||
|
||||
@defmethod[#:mode pubment
|
||||
(on-save-file [filename path?]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr)])
|
||||
[format (or/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr)])
|
||||
void?]{
|
||||
@methspec{
|
||||
|
||||
|
|
@ -1712,7 +1712,7 @@ To extend or re-implement copying, override the @xmethod[text%
|
|||
|
||||
@defmethod[(print [interactive? any/c #t]
|
||||
[fit-on-page? any/c #t]
|
||||
[output-mode (one-of/c 'standard 'postscript) 'standard]
|
||||
[output-mode (or/c 'standard 'postscript) 'standard]
|
||||
[parent (or/c (or/c (is-a?/c frame%) (is-a?/c dialog%)) #f) #f]
|
||||
[force-ps-page-bbox? any/c #t]
|
||||
[as-eps? any/c #f])
|
||||
|
|
@ -1891,7 +1891,7 @@ See also @method[editor<%> add-undo].
|
|||
[y real?]
|
||||
[width (and/c real? (not/c negative?))]
|
||||
[height (and/c real? (not/c negative?))]
|
||||
[draw-caret (one-of/c 'no-caret 'show-inactive-caret 'show-caret)]
|
||||
[draw-caret (or/c 'no-caret 'show-inactive-caret 'show-caret)]
|
||||
[background (or/c (is-a?/c color%) #f)])
|
||||
void?]{
|
||||
|
||||
|
|
@ -1973,8 +1973,8 @@ If @scheme[redraw-now?] is @scheme[#f], the editor will require
|
|||
|
||||
|
||||
@defmethod[(save-file [filename (or/c path-string? #f) #f]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'same]
|
||||
[format (or/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'same]
|
||||
[show-errors? any/c #t])
|
||||
boolean?]{
|
||||
|
||||
|
|
@ -2004,8 +2004,8 @@ The @scheme[show-errors?] argument is no longer used.
|
|||
|
||||
|
||||
@defmethod[(save-port [port output-port?]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'same]
|
||||
[format (or/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'same]
|
||||
[show-errors? any/c #t])
|
||||
boolean?]{
|
||||
|
||||
|
|
@ -2025,7 +2025,7 @@ The @scheme[show-errors?] argument is no longer used.
|
|||
[width (and/c real? (not/c negative?))]
|
||||
[height (and/c real? (not/c negative?))]
|
||||
[refresh? any/c]
|
||||
[bias (one-of/c 'start 'end 'none)])
|
||||
[bias (or/c 'start 'end 'none)])
|
||||
boolean?]{
|
||||
|
||||
Causes the editor to be scrolled so that a given @techlink{location}
|
||||
|
|
@ -2061,7 +2061,7 @@ For @scheme[text%] objects: @|FCA| @|EVD|
|
|||
[width (and/c real? (not/c negative?))]
|
||||
[height (and/c real? (not/c negative?))]
|
||||
[refresh? any/c]
|
||||
[bias (one-of/c 'start 'end 'none) 'none])
|
||||
[bias (or/c 'start 'end 'none) 'none])
|
||||
boolean?]{
|
||||
|
||||
Called (indirectly) by snips within the editor: it causes the editor
|
||||
|
|
@ -2120,7 +2120,7 @@ get-admin]}]
|
|||
|
||||
|
||||
@defmethod[(set-caret-owner [snip (or/c (is-a?/c snip%) #f)]
|
||||
[domain (one-of/c 'immediate 'display 'global) 'immediate])
|
||||
[domain (or/c 'immediate 'display 'global) 'immediate])
|
||||
void?]{
|
||||
|
||||
Attempts to give the keyboard focus to @scheme[snip]. If @scheme[snip] is
|
||||
|
|
@ -2195,7 +2195,7 @@ This method is also called when the filename changes through any
|
|||
}
|
||||
|
||||
|
||||
@defmethod[(set-inactive-caret-threshold [threshold (one-of/c 'no-caret 'show-inactive-caret 'show-caret)])
|
||||
@defmethod[(set-inactive-caret-threshold [threshold (or/c 'no-caret 'show-inactive-caret 'show-caret)])
|
||||
void?]{
|
||||
|
||||
Sets the threshold for painting an inactive selection. See
|
||||
|
|
|
|||
|
|
@ -129,28 +129,28 @@ The family and face settings in a style delta are interdependent:
|
|||
|
||||
|
||||
|
||||
@defconstructor*/make[(([change-command (one-of/c 'change-nothing
|
||||
'change-normal
|
||||
'change-toggle-underline
|
||||
'change-toggle-size-in-pixels
|
||||
'change-normal-color
|
||||
'change-bold)
|
||||
@defconstructor*/make[(([change-command (or/c 'change-nothing
|
||||
'change-normal
|
||||
'change-toggle-underline
|
||||
'change-toggle-size-in-pixels
|
||||
'change-normal-color
|
||||
'change-bold)
|
||||
'change-nothing])
|
||||
([change-command (one-of/c 'change-family
|
||||
'change-style
|
||||
'change-toggle-style
|
||||
'change-weight
|
||||
'change-toggle-weight
|
||||
'change-smoothing
|
||||
'change-toggle-smoothing
|
||||
'change-alignment)]
|
||||
([change-command (or/c 'change-family
|
||||
'change-style
|
||||
'change-toggle-style
|
||||
'change-weight
|
||||
'change-toggle-weight
|
||||
'change-smoothing
|
||||
'change-toggle-smoothing
|
||||
'change-alignment)]
|
||||
[v symbol])
|
||||
([change-command (one-of/c 'change-size
|
||||
'change-bigger
|
||||
'change-smaller)]
|
||||
([change-command (or/c 'change-size
|
||||
'change-bigger
|
||||
'change-smaller)]
|
||||
[v (integer-in 0 255)])
|
||||
([change-command (one-of/c 'change-underline
|
||||
'change-size-in-pixels)]
|
||||
([change-command (or/c 'change-underline
|
||||
'change-size-in-pixels)]
|
||||
[v any/c]))]{
|
||||
|
||||
The initialization arguments are passed on to
|
||||
|
|
@ -186,14 +186,14 @@ Returns @scheme[#t] if the given delta is equivalent to this one in
|
|||
}
|
||||
|
||||
@defmethod[(get-alignment-off)
|
||||
(one-of/c 'base 'top 'center 'bottom)]{
|
||||
(or/c 'base 'top 'center 'bottom)]{
|
||||
|
||||
See @scheme[style-delta%].
|
||||
|
||||
}
|
||||
|
||||
@defmethod[(get-alignment-on)
|
||||
(one-of/c 'base 'top 'center 'bottom)]{
|
||||
(or/c 'base 'top 'center 'bottom)]{
|
||||
|
||||
See @scheme[style-delta%].
|
||||
|
||||
|
|
@ -232,8 +232,8 @@ See also @method[style-delta% get-family].
|
|||
}
|
||||
|
||||
@defmethod[(get-family)
|
||||
(one-of/c 'base 'default 'decorative 'roman 'script
|
||||
'swiss 'modern 'symbol 'system)]{
|
||||
(or/c 'base 'default 'decorative 'roman 'script
|
||||
'swiss 'modern 'symbol 'system)]{
|
||||
|
||||
Returns the delta's font family. The possible values are
|
||||
@itemize[
|
||||
|
|
@ -301,24 +301,24 @@ Gets the multiplicative font size shift (applied before the additive factor).
|
|||
}
|
||||
|
||||
@defmethod[(get-smoothing-off)
|
||||
(one-of/c 'base 'default 'partly-smoothed 'smoothed 'unsmoothed)]{
|
||||
(or/c 'base 'default 'partly-smoothed 'smoothed 'unsmoothed)]{
|
||||
|
||||
See @scheme[style-delta%].
|
||||
|
||||
}
|
||||
|
||||
@defmethod[(get-smoothing-on)
|
||||
(one-of/c 'base 'default 'partly-smoothed 'smoothed 'unsmoothed)]{See
|
||||
(or/c 'base 'default 'partly-smoothed 'smoothed 'unsmoothed)]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod[(get-style-off)
|
||||
(one-of/c 'base 'normal 'italic 'slant)]{See
|
||||
(or/c 'base 'normal 'italic 'slant)]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod[(get-style-on)
|
||||
(one-of/c 'base 'normal 'italic 'slant)]{See
|
||||
(or/c 'base 'normal 'italic 'slant)]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
|
|
@ -343,50 +343,50 @@ See @scheme[style-delta%].
|
|||
}
|
||||
|
||||
@defmethod[(get-weight-off)
|
||||
(one-of/c 'base 'normal 'bold 'light)]{See
|
||||
(or/c 'base 'normal 'bold 'light)]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod[(get-weight-on)
|
||||
(one-of/c 'base 'normal 'bold 'light)]{See
|
||||
(or/c 'base 'normal 'bold 'light)]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod[(set-alignment-off [v (one-of/c 'base 'top 'center 'bottom)])
|
||||
@defmethod[(set-alignment-off [v (or/c 'base 'top 'center 'bottom)])
|
||||
void?]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod[(set-alignment-on [v (one-of/c 'base 'top 'center 'bottom)])
|
||||
@defmethod[(set-alignment-on [v (or/c 'base 'top 'center 'bottom)])
|
||||
void?]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod*[([(set-delta [change-command (one-of/c 'change-nothing
|
||||
'change-normal
|
||||
'change-toggle-underline
|
||||
'change-toggle-size-in-pixels
|
||||
'change-normal-color
|
||||
'change-bold)
|
||||
@defmethod*[([(set-delta [change-command (or/c 'change-nothing
|
||||
'change-normal
|
||||
'change-toggle-underline
|
||||
'change-toggle-size-in-pixels
|
||||
'change-normal-color
|
||||
'change-bold)
|
||||
'change-nothing])
|
||||
(is-a?/c style-delta%)]
|
||||
[(set-delta [change-command (one-of/c 'change-family
|
||||
'change-style
|
||||
'change-toggle-style
|
||||
'change-weight
|
||||
'change-toggle-weight
|
||||
'change-smoothing
|
||||
'change-toggle-smoothing
|
||||
'change-alignment)]
|
||||
[(set-delta [change-command (or/c 'change-family
|
||||
'change-style
|
||||
'change-toggle-style
|
||||
'change-weight
|
||||
'change-toggle-weight
|
||||
'change-smoothing
|
||||
'change-toggle-smoothing
|
||||
'change-alignment)]
|
||||
[param symbol])
|
||||
(is-a?/c style-delta%)]
|
||||
[(set-delta [change-command (one-of/c 'change-size
|
||||
'change-bigger
|
||||
'change-smaller)]
|
||||
[(set-delta [change-command (or/c 'change-size
|
||||
'change-bigger
|
||||
'change-smaller)]
|
||||
[param (integer-in 0 255)])
|
||||
(is-a?/c style-delta%)]
|
||||
[(set-delta [change-command (one-of/c 'change-underline
|
||||
'change-size-in-pixels)]
|
||||
[(set-delta [change-command (or/c 'change-underline
|
||||
'change-size-in-pixels)]
|
||||
[on? any/c])
|
||||
(is-a?/c style-delta%)])]{
|
||||
|
||||
|
|
@ -455,8 +455,8 @@ For the case that a string color name is supplied, see
|
|||
}
|
||||
|
||||
@defmethod[(set-delta-face [name string?]
|
||||
[family (one-of/c 'base 'default 'decorative 'roman
|
||||
'script 'swiss 'modern 'symbol 'system)
|
||||
[family (or/c 'base 'default 'decorative 'roman
|
||||
'script 'swiss 'modern 'symbol 'system)
|
||||
'default])
|
||||
(is-a?/c style-delta%)]{
|
||||
|
||||
|
|
@ -493,8 +493,8 @@ For the case that a string color name is supplied, see
|
|||
|
||||
}
|
||||
|
||||
@defmethod[(set-family [v (one-of/c 'base 'default 'decorative 'roman 'script
|
||||
'swiss 'modern 'symbol 'system)])
|
||||
@defmethod[(set-family [v (or/c 'base 'default 'decorative 'roman 'script
|
||||
'swiss 'modern 'symbol 'system)])
|
||||
void?]{
|
||||
Sets the delta's font family. See
|
||||
@method[style-delta% get-family].
|
||||
|
|
@ -521,22 +521,22 @@ after the multiplicative factor).
|
|||
before the additive factor).
|
||||
}
|
||||
|
||||
@defmethod[(set-smoothing-off [v (one-of/c 'base 'default 'partly-smoothed 'smoothed 'unsmoothed)])
|
||||
@defmethod[(set-smoothing-off [v (or/c 'base 'default 'partly-smoothed 'smoothed 'unsmoothed)])
|
||||
void?]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod[(set-smoothing-on [v (one-of/c 'base 'default 'partly-smoothed 'smoothed 'unsmoothed)])
|
||||
@defmethod[(set-smoothing-on [v (or/c 'base 'default 'partly-smoothed 'smoothed 'unsmoothed)])
|
||||
void?]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod[(set-style-off [v (one-of/c 'base 'normal 'italic 'slant)])
|
||||
@defmethod[(set-style-off [v (or/c 'base 'normal 'italic 'slant)])
|
||||
void?]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod[(set-style-on [v (one-of/c 'base 'normal 'italic 'slant)])
|
||||
@defmethod[(set-style-on [v (or/c 'base 'normal 'italic 'slant)])
|
||||
void?]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
|
@ -561,12 +561,12 @@ before the additive factor).
|
|||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod[(set-weight-off [v (one-of/c 'base 'normal 'bold 'light)])
|
||||
@defmethod[(set-weight-off [v (or/c 'base 'normal 'bold 'light)])
|
||||
void?]{See
|
||||
@scheme[style-delta%].
|
||||
}
|
||||
|
||||
@defmethod[(set-weight-on [v (one-of/c 'base 'normal 'bold 'light)])
|
||||
@defmethod[(set-weight-on [v (or/c 'base 'normal 'bold 'light)])
|
||||
void?]{See
|
||||
@scheme[style-delta%].
|
||||
}}
|
||||
|
|
|
|||
|
|
@ -519,7 +519,7 @@ Given a @techlink{location} in the editor, returns the line at the
|
|||
}
|
||||
|
||||
|
||||
@defmethod[(find-newline [direction (one-of/c 'forward 'backward) 'forward]
|
||||
@defmethod[(find-newline [direction (or/c 'forward 'backward) 'forward]
|
||||
[start (or/c exact-nonnegative-integer? 'start) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'eof) 'eof])
|
||||
(or/c exact-nonnegative-integer? #f)]{
|
||||
|
|
@ -590,7 +590,7 @@ See @method[text% find-position] for a discussion of
|
|||
|
||||
|
||||
@defmethod[(find-snip [pos exact-nonnegative-integer?]
|
||||
[direction (one-of/c 'before-or-none 'before 'after 'after-or-none)]
|
||||
[direction (or/c 'before-or-none 'before 'after 'after-or-none)]
|
||||
[s-pos (or/c (box/c exact-nonnegative-integer?) #f) #f])
|
||||
(or/c (is-a?/c snip%) #f)]{
|
||||
|
||||
|
|
@ -622,7 +622,7 @@ can be any of the following:
|
|||
|
||||
|
||||
@defmethod[(find-string [str string?]
|
||||
[direction (one-of/c 'forward 'backward) 'forward]
|
||||
[direction (or/c 'forward 'backward) 'forward]
|
||||
[start (or/c exact-nonnegative-integer? 'start) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'eof) 'eof]
|
||||
[get-start? any/c #t]
|
||||
|
|
@ -654,7 +654,7 @@ If @scheme[case-sensitive?] is @scheme[#f], then an uppercase and lowercase
|
|||
|
||||
|
||||
@defmethod[(find-string-all [str string?]
|
||||
[direction (one-of/c 'forward 'backward) 'forward]
|
||||
[direction (or/c 'forward 'backward) 'forward]
|
||||
[start (or/c exact-nonnegative-integer? 'start) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'eof) 'eof]
|
||||
[get-start? any/c #t]
|
||||
|
|
@ -670,7 +670,7 @@ Finds all occurrences of a string using @method[text% find-string]. If
|
|||
|
||||
@defmethod[(find-wordbreak [start (or/c (box/c exact-nonnegative-integer?) #f)]
|
||||
[end (or/c (box/c exact-nonnegative-integer?) #f)]
|
||||
[reason (one-of/c 'caret 'line 'selection 'user1 'user2)])
|
||||
[reason (or/c 'caret 'line 'selection 'user1 'user2)])
|
||||
void?]{
|
||||
|
||||
Finds wordbreaks in the editor using the current wordbreak procedure.
|
||||
|
|
@ -789,7 +789,7 @@ Returns the ending @techlink{position} of the current selection. See
|
|||
|
||||
|
||||
@defmethod[(get-file-format)
|
||||
(one-of/c 'standard 'text 'text-force-cr)]{
|
||||
(or/c 'standard 'text 'text-force-cr)]{
|
||||
|
||||
Returns the format of the last file saved from or loaded into this
|
||||
editor. See also @method[editor<%> load-file].
|
||||
|
|
@ -1259,9 +1259,9 @@ then this method ignores the editor's maximum width and any automatic
|
|||
}
|
||||
|
||||
|
||||
@defmethod[(move-position [code (one-of/c 'home 'end 'right 'left 'up 'down)]
|
||||
@defmethod[(move-position [code (or/c 'home 'end 'right 'left 'up 'down)]
|
||||
[extend? any/c #f]
|
||||
[kind (one-of/c 'simple 'word 'page 'line) 'simple])
|
||||
[kind (or/c 'simple 'word 'page 'line) 'simple])
|
||||
void?]{
|
||||
|
||||
Moves the current selection.
|
||||
|
|
@ -1720,7 +1720,7 @@ Removes all clickbacks installed for exactly the range @scheme[start]
|
|||
@defmethod[(scroll-to-position [start exact-nonnegative-integer?]
|
||||
[at-eol? any/c #f]
|
||||
[end (or/c exact-nonnegative-integer? 'same) 'same]
|
||||
[bias (one-of/c 'start 'end 'none) 'none])
|
||||
[bias (or/c 'start 'end 'none) 'none])
|
||||
boolean?]{
|
||||
|
||||
Scrolls the editor so that a given @techlink{position} is visible.
|
||||
|
|
@ -1836,7 +1836,7 @@ If @scheme[call-on-down?] is not @scheme[#f], the clickback is called
|
|||
See also @|clickbackdiscuss|.
|
||||
}
|
||||
|
||||
@defmethod[(set-file-format [format (one-of/c 'standard 'text 'text-force-cr)])
|
||||
@defmethod[(set-file-format [format (or/c 'standard 'text 'text-force-cr)])
|
||||
void?]{
|
||||
|
||||
Set the format of the file saved from this editor.
|
||||
|
|
@ -1875,7 +1875,7 @@ Enables or disables overwrite mode. See @method[text%
|
|||
|
||||
|
||||
@defmethod[(set-paragraph-alignment [paragraph exact-nonnegative-integer?]
|
||||
[alignment (one-of/c 'left 'center 'right)])
|
||||
[alignment (or/c 'left 'center 'right)])
|
||||
void?]{
|
||||
|
||||
Sets a paragraph-specific horizontal alignment. The alignment is only
|
||||
|
|
@ -1917,7 +1917,7 @@ The first line of the paragraph is indented by @scheme[first-left] points
|
|||
[end (or/c exact-nonnegative-integer? 'same) 'same]
|
||||
[at-eol? any/c #f]
|
||||
[scroll? any/c #t]
|
||||
[seltype (one-of/c 'default 'x 'local) 'default])
|
||||
[seltype (or/c 'default 'x 'local) 'default])
|
||||
void?]{
|
||||
|
||||
Sets the current selection in the editor.
|
||||
|
|
@ -1956,12 +1956,12 @@ See also @scheme[editor-set-x-selection-mode].
|
|||
}
|
||||
|
||||
|
||||
@defmethod[(set-position-bias-scroll [bias (one-of/c 'start-only 'start 'none 'end 'end-only)]
|
||||
@defmethod[(set-position-bias-scroll [bias (or/c 'start-only 'start 'none 'end 'end-only)]
|
||||
[start exact-nonnegative-integer?]
|
||||
[end (or/c exact-nonnegative-integer? 'same) 'same]
|
||||
[ateol? any/c #f]
|
||||
[scroll? any/c #t]
|
||||
[seltype (one-of/c 'default 'x 'local) 'default])
|
||||
[seltype (or/c 'default 'x 'local) 'default])
|
||||
void?]{
|
||||
|
||||
Like @method[text% set-position], but a scrolling bias can be specified.
|
||||
|
|
|
|||
338
collects/tests/compiler/zo-test.ss
Normal file
338
collects/tests/compiler/zo-test.ss
Normal file
|
|
@ -0,0 +1,338 @@
|
|||
#lang scheme
|
||||
(require compiler/zo-parse
|
||||
compiler/zo-marshal
|
||||
compiler/decompile
|
||||
setup/dirs)
|
||||
|
||||
;; Helpers
|
||||
(define (bytes-gulp f)
|
||||
(with-input-from-file f
|
||||
(λ () (port->bytes (current-input-port)))))
|
||||
(define (zo-parse/bytes bs)
|
||||
(define ib (open-input-bytes bs))
|
||||
(dynamic-wind void
|
||||
(lambda ()
|
||||
(zo-parse ib))
|
||||
(lambda ()
|
||||
(close-input-port ib))))
|
||||
|
||||
(define (bytes-not-equal?-error b1 b2)
|
||||
(unless (bytes=? b1 b2)
|
||||
(error 'bytes-not-equal?-error "Not equal")))
|
||||
|
||||
(define (replace-file file bytes)
|
||||
(with-output-to-file file
|
||||
(λ () (write-bytes bytes))
|
||||
#:exists 'truncate))
|
||||
|
||||
(define ((make-recorder! ht) file phase)
|
||||
(hash-update! ht phase (curry list* file) empty))
|
||||
|
||||
(define (equal?/why-not v1 v2)
|
||||
(define (yield p m v1 v2)
|
||||
(error 'equal?/why-not "~a in ~a: ~S ~S"
|
||||
m (reverse p) v1 v2))
|
||||
(define (inner p v1 v2)
|
||||
(unless (eq? v1 v2)
|
||||
(match v1
|
||||
[(cons car1 cdr1)
|
||||
(match v2
|
||||
[(cons car2 cdr2)
|
||||
(inner (list* 'car p) car1 car2)
|
||||
(inner (list* 'cdr p) cdr1 cdr2)]
|
||||
[_
|
||||
(yield p "Not a cons on right" v1 v2)])]
|
||||
[(? vector?)
|
||||
(match v2
|
||||
[(? vector?)
|
||||
(define v1l (vector-length v1))
|
||||
(define v2l (vector-length v2))
|
||||
(if (= v1l v2l)
|
||||
(for ([i (in-range v1l)])
|
||||
(inner (list* `(vector-ref ,i) p)
|
||||
(vector-ref v1 i)
|
||||
(vector-ref v2 i)))
|
||||
(yield p "Vector lengths not equal" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a vector on right" v1 v2)])]
|
||||
[(? struct?)
|
||||
(match v2
|
||||
[(? struct?)
|
||||
(define vv1 (struct->vector v1))
|
||||
(define vv2 (struct->vector v2))
|
||||
(inner (list* `(struct->vector ,(vector-ref vv1 0)) p)
|
||||
vv1 vv2)]
|
||||
[_
|
||||
(yield p "Not a struct on right" v1 v2)])]
|
||||
[(? hash?)
|
||||
(match v2
|
||||
[(? hash?)
|
||||
(let ([p (list* 'in-hash p)])
|
||||
(for ([(k1 hv1) (in-hash v1)])
|
||||
(define hv2
|
||||
(hash-ref v2 k1
|
||||
(lambda ()
|
||||
(yield p (format "~S not in hash on right" k1) v1 v2))))
|
||||
(inner (list* `(hash-ref ,k1) p)
|
||||
hv1 hv2)))]
|
||||
[_
|
||||
(yield p "Not a hash on right" v1 v2)])]
|
||||
[(? module-path-index?)
|
||||
(match v2
|
||||
[(? module-path-index?)
|
||||
(define-values (mp1 bmpi1) (module-path-index-split v1))
|
||||
(define-values (mp2 bmpi2) (module-path-index-split v2))
|
||||
(inner (list* 'module-path-index-split_0 p) mp1 mp2)
|
||||
(inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)]
|
||||
[_
|
||||
(yield p "Not a module path index on right" v1 v2)])]
|
||||
[(? string?)
|
||||
(match v2
|
||||
[(? string?)
|
||||
(unless (string=? v1 v2)
|
||||
(yield p "Unequal strings" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a string on right" v1 v2)])]
|
||||
[(? path?)
|
||||
(match v2
|
||||
[(? path?)
|
||||
(unless (equal? v1 v2)
|
||||
(yield p "Unequal paths" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a path on right" v1 v2)])]
|
||||
[(? number?)
|
||||
(match v2
|
||||
[(? number?)
|
||||
(unless (equal? v1 v2)
|
||||
(yield p "Unequal numbers" v1 v2))]
|
||||
[_
|
||||
(yield p "Not a number on right" v1 v2)])]
|
||||
[(? symbol?)
|
||||
(match v2
|
||||
[(? symbol?)
|
||||
(do-compare (symbol-interned?
|
||||
symbol-unreadable?)
|
||||
yield p v1 v2
|
||||
symbol=?)]
|
||||
[_
|
||||
(yield p "Not a symbol on right" v1 v2)])]
|
||||
[_
|
||||
(yield p "Cannot inspect values deeper" v1 v2)])))
|
||||
(inner empty v1 v2))
|
||||
|
||||
(define-syntax do-compare
|
||||
(syntax-rules ()
|
||||
[(_ () yield p v1 v2 =)
|
||||
(unless (= v1 v2)
|
||||
(yield p (format "Not ~a" '=) v1 v2))]
|
||||
[(_ (?1 ? ...) yield p v1 v2 =)
|
||||
(if (?1 v1)
|
||||
(if (?1 v2)
|
||||
(do-compare () yield (list* '?1 p) v1 v2 =)
|
||||
(yield p (format "Not ~a or right" '?1) v1 v2))
|
||||
(do-compare (? ...) yield p v1 v2 =))]))
|
||||
|
||||
;; Parameters
|
||||
(define stop-on-first-error (make-parameter #f))
|
||||
(define verbose-mode (make-parameter #f))
|
||||
(define care-about-nonserious? (make-parameter #t))
|
||||
(define invariant-output (make-parameter #f))
|
||||
(define time-limit (make-parameter +inf.0))
|
||||
(define randomize (make-parameter #f))
|
||||
|
||||
;; Work
|
||||
(define errors (make-hash))
|
||||
|
||||
(define (common-message exn)
|
||||
(define given-messages (regexp-match #rx".*given" (exn-message exn)))
|
||||
(if (and given-messages (not (empty? given-messages)))
|
||||
(first given-messages)
|
||||
(exn-message exn)))
|
||||
|
||||
(define (exn-printer file phase serious? exn)
|
||||
(hash-update! errors (common-message exn) add1 0)
|
||||
(unless (and (not (care-about-nonserious?)) (not serious?))
|
||||
(when (or (verbose-mode) (stop-on-first-error))
|
||||
(printf "~a -- ~a: ~a~n" file phase (exn-message exn)))
|
||||
(when (stop-on-first-error)
|
||||
exn)))
|
||||
|
||||
(define (run-with-time-limit t thnk)
|
||||
(define th (thread thnk))
|
||||
(sync th
|
||||
(handle-evt (alarm-evt (+ (current-inexact-milliseconds)
|
||||
(* 1000 t)))
|
||||
(lambda _
|
||||
(kill-thread th)))))
|
||||
|
||||
(define (run-with-limit file k thnk)
|
||||
(define file-custodian (make-custodian))
|
||||
(define ch (make-channel))
|
||||
(custodian-limit-memory file-custodian k)
|
||||
(local [(define worker-thread
|
||||
(parameterize ([current-custodian file-custodian])
|
||||
(thread
|
||||
(lambda ()
|
||||
(define r (thnk))
|
||||
(channel-put ch r)
|
||||
(channel-get ch)))))]
|
||||
(begin0
|
||||
(sync
|
||||
(handle-evt ch
|
||||
(lambda (v)
|
||||
(when (exn? v) (raise v))
|
||||
v))
|
||||
(handle-evt worker-thread
|
||||
(lambda _
|
||||
(failure! file 'memory))))
|
||||
(custodian-shutdown-all file-custodian))))
|
||||
|
||||
(define success-ht (make-hasheq))
|
||||
(define success! (make-recorder! success-ht))
|
||||
(define failure-ht (make-hasheq))
|
||||
(define failure! (make-recorder! failure-ht))
|
||||
|
||||
(define-syntax run/stages*
|
||||
(syntax-rules ()
|
||||
[(_ file) (success! file 'everything)]
|
||||
[(_ file [step1 serious? e] . rst)
|
||||
(let/ec esc
|
||||
(let ([step1 (with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
(failure! file 'step1)
|
||||
(esc (exn-printer file 'step1 serious? x)))])
|
||||
e)])
|
||||
(success! file 'step1)
|
||||
(run/stages* file . rst)))]))
|
||||
|
||||
(define-syntax-rule (define-stages (stages run!)
|
||||
file
|
||||
[stage serious? e] ...)
|
||||
(define-values (stages run!)
|
||||
(values '(stage ...)
|
||||
(lambda (file)
|
||||
(run/stages* file [stage serious? e] ...)))))
|
||||
|
||||
(define-stages (stages run!)
|
||||
file
|
||||
[read-orig
|
||||
#t
|
||||
(bytes-gulp file)]
|
||||
[parse-orig
|
||||
#t
|
||||
(zo-parse/bytes read-orig)]
|
||||
[marshal-parsed
|
||||
#t
|
||||
(zo-marshal parse-orig)]
|
||||
#;[ignored
|
||||
#f
|
||||
(printf "orig: ~a, marshalled: ~a~n"
|
||||
(bytes-length read-orig)
|
||||
(bytes-length marshal-parsed))]
|
||||
[parse-marshalled
|
||||
#t
|
||||
(zo-parse/bytes marshal-parsed)]
|
||||
[compare-parsed-to-parsed-marshalled
|
||||
#f
|
||||
(equal?/why-not parse-orig parse-marshalled)]
|
||||
[marshal-marshalled
|
||||
#t
|
||||
(zo-marshal parse-marshalled)]
|
||||
[compare-marshalled-to-marshalled-marshalled
|
||||
#f
|
||||
(bytes-not-equal?-error marshal-parsed marshal-marshalled)]
|
||||
#;[replace-with-marshalled
|
||||
#t
|
||||
(replace-file file marshal-marshalled)]
|
||||
[decompile-parsed
|
||||
#t
|
||||
(decompile parse-orig)]
|
||||
[compare-orig-to-marshalled
|
||||
#f
|
||||
(bytes-not-equal?-error read-orig marshal-parsed)])
|
||||
|
||||
(define (run-test file)
|
||||
(run-with-limit
|
||||
file
|
||||
(* 1024 1024 128)
|
||||
(lambda ()
|
||||
(run! file))))
|
||||
|
||||
(define (randomize-list l)
|
||||
(define ll (length l))
|
||||
(define seen? (make-hasheq))
|
||||
(let loop ([t 0])
|
||||
(if (= t ll)
|
||||
empty
|
||||
(let ([i (random ll)])
|
||||
(if (hash-has-key? seen? i)
|
||||
(loop t)
|
||||
(begin (hash-set! seen? i #t)
|
||||
(list* (list-ref l i)
|
||||
(loop (add1 t)))))))))
|
||||
|
||||
(define (maybe-randomize-list l)
|
||||
(if (randomize) (randomize-list l) l))
|
||||
|
||||
(define (for-zos ! p)
|
||||
(define p-str (if (path? p) (path->string p) p))
|
||||
(cond
|
||||
[(directory-exists? p)
|
||||
(for ([sp (in-list (maybe-randomize-list (directory-list p)))])
|
||||
(for-zos ! (build-path p sp)))]
|
||||
[(regexp-match #rx"\\.zo$" p-str)
|
||||
(! p-str)]))
|
||||
|
||||
(define (zo-test paths)
|
||||
(run-with-time-limit
|
||||
(time-limit)
|
||||
(lambda ()
|
||||
(for-each (curry for-zos run-test) paths)))
|
||||
|
||||
(unless (invariant-output)
|
||||
(for ([kind-name (list* 'memory stages)])
|
||||
(define fails (length (hash-ref failure-ht kind-name empty)))
|
||||
(define succs (length (hash-ref success-ht kind-name empty)))
|
||||
(define all (+ fails succs))
|
||||
(unless (zero? all)
|
||||
(printf "~S~n"
|
||||
`(,kind-name
|
||||
(#f ,fails)
|
||||
(#t ,succs)
|
||||
,all))))
|
||||
(printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty)))
|
||||
|
||||
(printf "Common Errors:~n")
|
||||
|
||||
(for ([p (in-list (sort (filter (λ (p) ((car p) . > . 10))
|
||||
(hash-map errors (λ (k v) (cons v k))))
|
||||
> #:key car))])
|
||||
(printf "~a:~n~a~n~n" (car p) (cdr p)))))
|
||||
|
||||
; Run
|
||||
#;(current-command-line-arguments #("-s" "/home/bjohn3x/development/plt/collects/browser/compiled/browser_scrbl.zo"))
|
||||
(command-line #:program "zo-test"
|
||||
#:once-each
|
||||
[("-s" "--stop-on-first-error")
|
||||
"Stop testing when first error is encountered"
|
||||
(stop-on-first-error #t)]
|
||||
[("-S")
|
||||
"Don't take some errors seriously"
|
||||
(care-about-nonserious? #f)]
|
||||
[("-v" "--verbose")
|
||||
"Display verbose error messages"
|
||||
(verbose-mode #t)]
|
||||
[("-I")
|
||||
"Invariant output"
|
||||
(invariant-output #t)]
|
||||
[("-R")
|
||||
"Randomize"
|
||||
(randomize #t)]
|
||||
[("-t")
|
||||
number
|
||||
"Limit the run to a given amount of time"
|
||||
(time-limit (string->number number))]
|
||||
#:args p
|
||||
(zo-test (if (empty? p)
|
||||
(list (find-collects-dir))
|
||||
p)))
|
||||
|
|
@ -5,14 +5,14 @@
|
|||
(let ([basics (list "Bring Frame to Front..." "Most Recent Window"
|
||||
#f)])
|
||||
(if (eq? (system-type) 'macosx)
|
||||
(list* "Minimize" "Zoom" basics)
|
||||
basics)))
|
||||
(list* "Minimize" "Zoom" basics)
|
||||
basics)))
|
||||
(send-sexp-to-mred
|
||||
'(define-syntax car*
|
||||
(syntax-rules ()
|
||||
[(car* x) (if (pair? x)
|
||||
(car x)
|
||||
(error 'car* "got a non-pair for ~s" 'x))])))
|
||||
(car x)
|
||||
(error 'car* "got a non-pair for ~s" 'x))])))
|
||||
|
||||
;; this test uses a new eventspace so that the mred function
|
||||
;; current-eventspace-has-standard-menus? returns #f and thus
|
||||
|
|
@ -54,7 +54,7 @@
|
|||
(send-sexp-to-mred
|
||||
`(begin0 (map (lambda (x) (send x get-label))
|
||||
(send (group:get-the-frame-group) get-frames))
|
||||
(send (get-top-level-focus-window) close)))))
|
||||
(send (get-top-level-focus-window) close)))))
|
||||
|
||||
(test
|
||||
'two-frames-registered
|
||||
|
|
@ -94,89 +94,92 @@
|
|||
frames)
|
||||
(map (lambda (x) (send x get-label)) frames)))))
|
||||
|
||||
(test
|
||||
'windows-menu
|
||||
(lambda (x)
|
||||
(equal? x (append windows-menu-prefix (list "first" "test"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame (make-object frame:basic% "test")])
|
||||
(send frame show #t)))
|
||||
(wait-for-frame "test")
|
||||
(send-sexp-to-mred
|
||||
'(begin0 (map (lambda (x)
|
||||
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
||||
(send (car* (send (send (get-top-level-focus-window)
|
||||
get-menu-bar)
|
||||
get-items))
|
||||
get-items))
|
||||
(send (get-top-level-focus-window) close)))))
|
||||
|
||||
(test
|
||||
'windows-menu-unshown
|
||||
(lambda (x)
|
||||
(equal? x (append windows-menu-prefix (list "first" "test"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame1 (make-object frame:basic% "test")]
|
||||
[frame2 (make-object frame:basic% "test-not-shown")])
|
||||
(send frame1 show #t)))
|
||||
(wait-for-frame "test")
|
||||
(send-sexp-to-mred
|
||||
'(begin0 (map (lambda (x)
|
||||
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
||||
(send (car* (send (send (get-top-level-focus-window)
|
||||
get-menu-bar)
|
||||
get-items))
|
||||
get-items))
|
||||
(send (get-top-level-focus-window) close)))))
|
||||
|
||||
(test
|
||||
'windows-menu-sorted1
|
||||
(lambda (x)
|
||||
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame (make-object frame:basic% "aaa")])
|
||||
(send frame show #t)))
|
||||
(wait-for-frame "aaa")
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame (make-object frame:basic% "bbb")])
|
||||
(send frame show #t)))
|
||||
(wait-for-frame "bbb")
|
||||
(send-sexp-to-mred
|
||||
`(let ([frames (send (group:get-the-frame-group) get-frames)])
|
||||
(begin0 (map (lambda (x)
|
||||
(when (eq? (system-type) 'macosx)
|
||||
|
||||
(test
|
||||
'windows-menu
|
||||
(lambda (x)
|
||||
(equal? x (append windows-menu-prefix (list "first" "test"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame (make-object frame:basic% "test")])
|
||||
(send frame show #t)))
|
||||
(wait-for-frame "test")
|
||||
(send-sexp-to-mred
|
||||
'(begin0 (map (lambda (x)
|
||||
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
||||
(send (car* (send (send (car* frames) get-menu-bar)
|
||||
(send (car* (send (send (get-top-level-focus-window)
|
||||
get-menu-bar)
|
||||
get-items))
|
||||
get-items))
|
||||
(for-each (lambda (x)
|
||||
(unless (equal? (send x get-label) "first")
|
||||
(send x close)))
|
||||
frames))))))
|
||||
|
||||
(test
|
||||
'windows-menu-sorted2
|
||||
(lambda (x)
|
||||
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame (make-object frame:basic% "bbb")])
|
||||
(send frame show #t)))
|
||||
(wait-for-frame "bbb")
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame (make-object frame:basic% "aaa")])
|
||||
(send frame show #t)))
|
||||
(wait-for-frame "aaa")
|
||||
(send-sexp-to-mred
|
||||
`(let ([frames (send (group:get-the-frame-group) get-frames)])
|
||||
(begin0 (map (lambda (x)
|
||||
(send (get-top-level-focus-window) close)))))
|
||||
|
||||
(test
|
||||
'windows-menu-unshown
|
||||
(lambda (x)
|
||||
(equal? x (append windows-menu-prefix (list "first" "test"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame1 (make-object frame:basic% "test")]
|
||||
[frame2 (make-object frame:basic% "test-not-shown")])
|
||||
(send frame1 show #t)))
|
||||
(wait-for-frame "test")
|
||||
(send-sexp-to-mred
|
||||
'(begin0 (map (lambda (x)
|
||||
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
||||
(send (car* (send (send (car* frames) get-menu-bar)
|
||||
(send (car* (send (send (get-top-level-focus-window)
|
||||
get-menu-bar)
|
||||
get-items))
|
||||
get-items))
|
||||
(for-each (lambda (x)
|
||||
(unless (equal? (send x get-label) "first")
|
||||
(send x close)))
|
||||
frames))))))
|
||||
(send (get-top-level-focus-window) close)))))
|
||||
|
||||
(test
|
||||
'windows-menu-sorted1
|
||||
(lambda (x)
|
||||
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame (make-object frame:basic% "aaa")])
|
||||
(send frame show #t)))
|
||||
(wait-for-frame "aaa")
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame (make-object frame:basic% "bbb")])
|
||||
(send frame show #t)))
|
||||
(wait-for-frame "bbb")
|
||||
(send-sexp-to-mred
|
||||
`(let ([frames (send (group:get-the-frame-group) get-frames)])
|
||||
(begin0 (map (lambda (x)
|
||||
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
||||
(send (car* (send (send (car* frames) get-menu-bar)
|
||||
get-items))
|
||||
get-items))
|
||||
(for-each (lambda (x)
|
||||
(unless (equal? (send x get-label) "first")
|
||||
(send x close)))
|
||||
frames))))))
|
||||
|
||||
(test
|
||||
'windows-menu-sorted2
|
||||
(lambda (x)
|
||||
(equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame (make-object frame:basic% "bbb")])
|
||||
(send frame show #t)))
|
||||
(wait-for-frame "bbb")
|
||||
(send-sexp-to-mred
|
||||
'(let ([frame (make-object frame:basic% "aaa")])
|
||||
(send frame show #t)))
|
||||
(wait-for-frame "aaa")
|
||||
(send-sexp-to-mred
|
||||
`(let ([frames (send (group:get-the-frame-group) get-frames)])
|
||||
(begin0 (map (lambda (x)
|
||||
(and (is-a? x labelled-menu-item<%>) (send x get-label)))
|
||||
(send (car* (send (send (car* frames) get-menu-bar)
|
||||
get-items))
|
||||
get-items))
|
||||
(for-each (lambda (x)
|
||||
(unless (equal? (send x get-label) "first")
|
||||
(send x close)))
|
||||
frames))))))
|
||||
)
|
||||
|
|
@ -25,29 +25,14 @@
|
|||
(fprintf port "#lang plai/mutator\n")
|
||||
(fprintf port "~s\n" `(allocator-setup ,(path->string
|
||||
(find-relative-path
|
||||
(normalize-path (simple-form-path tmpfile))
|
||||
(let-values ([(base name dir?) (split-path tmpfile)])
|
||||
(normalize-path (simple-form-path base)))
|
||||
(normalize-path
|
||||
(simple-form-path collector-path))))
|
||||
100))
|
||||
(for-each (λ (exp) (pretty-print exp port)) exps))
|
||||
#:exists 'truncate)
|
||||
|
||||
(printf "tmpfile: ~s\n" tmpfile)
|
||||
(printf "simple-form tmpfile ~s\n" (simple-form-path tmpfile))
|
||||
(printf "normalized tmpfile ~s\n" (normalize-path (simple-form-path tmpfile)))
|
||||
(newline)
|
||||
(printf "collector ~s\n" collector-path)
|
||||
(printf "simple-form collector: ~s\n" (simple-form-path collector-path))
|
||||
(printf "normalized simple-form collector: ~s\n" (normalize-path (simple-form-path collector-path)))
|
||||
(newline)
|
||||
(printf "here ~s\n" here)
|
||||
(printf "simple-form here: ~s\n" (simple-form-path here))
|
||||
(printf "normalized simple-form here: ~s\n" (normalize-path (simple-form-path here)))
|
||||
(newline)
|
||||
|
||||
(printf "tmpfile contents:\n")
|
||||
(call-with-input-file tmpfile (λ (p) (copy-port p (current-output-port))))
|
||||
|
||||
(let ([sp (open-output-string)])
|
||||
(parameterize ([current-output-port sp])
|
||||
(dynamic-require tmpfile #f))
|
||||
|
|
|
|||
|
|
@ -161,7 +161,7 @@ at least theoretically.
|
|||
|
||||
|
||||
;; turn contracts on and off - off by default for performance.
|
||||
(define-for-syntax enable-contracts? #t)
|
||||
(define-for-syntax enable-contracts? #f)
|
||||
(provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c)
|
||||
|
||||
;; these are versions of the contract forms conditionalized by `enable-contracts?'
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user