170 lines
5.5 KiB
Racket
170 lines
5.5 KiB
Racket
#lang scheme/gui
|
|
|
|
(define (find sym l)
|
|
(cond
|
|
[(null? l) null]
|
|
[(and (pair? (car l))
|
|
(eq? sym (caar l)))
|
|
(car l)]
|
|
[else (find sym (cdr l))]))
|
|
|
|
(define (add-method s table)
|
|
(let* ([s (if (keyword? (cadr s))
|
|
(cddr s)
|
|
s)]
|
|
[name (caadr s)]
|
|
[args (map cadr (cdadr s))])
|
|
(cons (cons name args)
|
|
table)))
|
|
|
|
(define (read-methods path kind table)
|
|
(let ([s (call-with-input-file* path (lambda (in)
|
|
(parameterize ([read-accept-reader #t])
|
|
(read in))))])
|
|
(for/fold ([table table])
|
|
([s (in-list (find kind s))])
|
|
(if (pair? s)
|
|
(cond
|
|
[(eq? (car s) 'defmethod)
|
|
(add-method s table)]
|
|
[else table])
|
|
table))))
|
|
|
|
(define editor-methods
|
|
(read-methods (build-path (collection-path "scribblings" "gui")
|
|
"editor-intf.scrbl")
|
|
'definterface/title
|
|
null))
|
|
|
|
(define (delete l l2)
|
|
(if (null? l)
|
|
l2
|
|
(delete (cdr l) (filter (lambda (p) (not (eq? (car l) (car p)))) l2))))
|
|
|
|
(define text-methods
|
|
(list->vector
|
|
(delete
|
|
'(read-header-from-file read-footer-from-file read-from-file
|
|
end-write-header-footer-to-file)
|
|
(read-methods (build-path (collection-path "scribblings" "gui")
|
|
"text-class.scrbl")
|
|
'defclass/title
|
|
(delete '(do-paste-x-selection do-paste do-copy) editor-methods)))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define bm-dc
|
|
(let ([bm (make-object bitmap% 10 10)])
|
|
(make-object bitmap-dc% bm)))
|
|
(define frame
|
|
(new frame% [label "Test"]))
|
|
(define canvas
|
|
(new editor-canvas% [parent frame]))
|
|
|
|
(define (generate-args contract-expr)
|
|
(if (pair? contract-expr)
|
|
(case (car contract-expr)
|
|
[(or/c one-of/c) (generate-args
|
|
(list-ref
|
|
(cdr contract-expr)
|
|
(random (length (cdr contract-expr)))))]
|
|
[(and/c)
|
|
(cond
|
|
[(equal? contract-expr '(and/c exact? integer?))
|
|
(generate-args 'exact-integer?)]
|
|
[(equal? contract-expr '(and/c real? (not/c negative?)))
|
|
(random-elem '#(0.0 1.0 100.0 1000.0))]
|
|
[else (error "unknown" contract-expr)])]
|
|
[(box/c) `(box ,(generate-args (cadr contract-expr)))]
|
|
[(listof) (case (random 3)
|
|
[(0) 'null]
|
|
[(1) (list 'list
|
|
(generate-args (cadr contract-expr)))]
|
|
[(2) (list 'list
|
|
(generate-args (cadr contract-expr))
|
|
(generate-args (cadr contract-expr)))])]
|
|
[(quote)
|
|
`(quote ,(cadr contract-expr))]
|
|
[(is-a?/c)
|
|
(case (cadr contract-expr)
|
|
[(editor-stream-out%)
|
|
(make-object editor-stream-out% (make-object editor-stream-out-bytes-base%))]
|
|
[(editor-stream-in%)
|
|
(make-object editor-stream-in% (make-object editor-stream-in-bytes-base% #""))]
|
|
[(snip%)
|
|
(let ([s (make-object string-snip%)])
|
|
(send s insert "hi" 2)
|
|
s)]
|
|
[(mouse-event%)
|
|
(make-object mouse-event% 'motion)]
|
|
[(key-event%)
|
|
(make-object key-event%)]
|
|
[(editor-data%) (new editor-data%)]
|
|
[(text%) (new text%)]
|
|
[(pasteboard%) (new pasteboard%)]
|
|
[(cursor%) (make-object cursor% 'arrow)]
|
|
[(style-delta%) (new style-delta%)]
|
|
[(style-list%) (new style-list%)]
|
|
[(style<%>) (send (new style-list%) basic-style)]
|
|
[(editor-canvas%) canvas]
|
|
[(frame% dialog%) frame]
|
|
[(dc<%>) bm-dc]
|
|
[(editor-admin%) (send t get-admin)]
|
|
[(bitmap%) (make-object bitmap% 10 10)]
|
|
[(color%) (new color%)]
|
|
[(keymap%) (new keymap%)]
|
|
[(editor-wordbreak-map%) (new editor-wordbreak-map%)]
|
|
[else (error "unknown" contract-expr)])]
|
|
[(->) void]
|
|
[else (error "unknown" contract-expr)])
|
|
(case contract-expr
|
|
[(any/c) #f]
|
|
[(path?) (string->path "/tmp/foo")]
|
|
[(path-string?) "/tmp/foo"]
|
|
[(input-port?) (open-input-bytes #"")]
|
|
[(output-port?) (open-output-bytes)]
|
|
[(real?)
|
|
(random-elem '#(0.0 1.0 -1.0 100.0 -100.0))]
|
|
[(exact-nonnegative-integer?)
|
|
(random-elem '#(0 1 2 10 100 1000))]
|
|
[(exact-integer?)
|
|
(random-elem '#(0 1 -1 2 10 -10 100 1000))]
|
|
[(string?)
|
|
(random-elem '#("a" "hello" ""))]
|
|
[(#f) #f]
|
|
[(#t) #t]
|
|
[else (error "unknown" contract-expr)])))
|
|
|
|
(define (random-elem v)
|
|
(vector-ref v (random (vector-length v))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define t (new text%))
|
|
|
|
; (send t copy-self)
|
|
; (send t begin-write-header-footer-to-file (generate-args '(is-a?/c editor-stream-out%)) "" (box 0))
|
|
; is-printing?
|
|
; #f for set-keymap
|
|
; seqcontract print
|
|
; undo error
|
|
; get-character
|
|
; blink-caret & no admin
|
|
; move-position & no admin
|
|
|
|
(define-namespace-anchor a)
|
|
|
|
(let ([n (abs (current-milliseconds))])
|
|
(printf "~s\n" n)
|
|
(random-seed n))
|
|
|
|
(parameterize ([current-namespace (namespace-anchor->namespace a)])
|
|
(let loop ()
|
|
(let ([m (random-elem text-methods)])
|
|
(let ([name (car m)]
|
|
[args (map generate-args (cdr m))])
|
|
(printf "Call ~s\n" (cons name args))
|
|
(eval `(send ,t ,(car m) ,@args))
|
|
(loop)))))
|
|
|