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

extend the example snip with wxme support

Browse Source 
and add some tests for the example
This commit is contained in:
Robby Findler 2015-12-17 10:07:54 -06:00
parent 6fd5459211
commit 23f22a8bcf
5 changed files with 218 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
gui-doc/info.rkt
View File

@ -13,6 +13,7 @@
"syntax-color-lib"
"wxme-lib"
"gui-lib"
"pict-lib"
"racket-doc"
"string-constants-doc"))
(define deps '("base"))

65
gui-doc/scribblings/gui/snip-example.rkt Normal file
View File

@ -0,0 +1,65 @@
#lang racket/base
(require racket/class
racket/snip
racket/format)
(provide circle-snip%
(rename-out [circle-snip-class snip-class]))
(define circle-snip%
(class snip%
(inherit set-snipclass
get-flags set-flags
get-admin)
(init-field [size 20.0])
(super-new)
(set-snipclass circle-snip-class)
(send (get-the-snip-class-list) add circle-snip-class)
(set-flags (cons 'handles-events (get-flags)))
(define/override (get-extent dc x y
[w #f]
[h #f]
[descent #f]
[space #f]
[lspace #f]
[rspace #f])
(define (maybe-set-box! b v) (when b (set-box! b v)))
(maybe-set-box! w (+ 2.0 size))
(maybe-set-box! h (+ 2.0 size))
(maybe-set-box! descent 1.0)
(maybe-set-box! space 1.0)
(maybe-set-box! lspace 1.0)
(maybe-set-box! rspace 1.0))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(send dc draw-ellipse (+ x 1.0) (+ y 1.0) size size))
(define/override (copy)
(new circle-snip% [size size]))
(define/override (write f)
(send f put size))
(define/override (on-event dc x y editorx editory e)
(when (send e button-down?)
(set! size (+ 1.0 size))
(define admin (get-admin))
(when admin
(send admin resized this #t))))))
(define circle-snip-class%
(class snip-class%
(inherit set-classname)
(super-new)
(set-classname (~s '((lib "main.rkt" "circle-snip")
(lib "wxme-circle-snip.rkt" "circle-snip"))))
(define/override (read f)
(define size-b (box 0.0))
(send f get size-b)
(new circle-snip% [size (unbox size-b)]))))
(define circle-snip-class (new circle-snip-class%))

87
gui-doc/scribblings/gui/snip-example.scrbl
View File

@ -1,5 +1,8 @@
#lang scribble/doc
@(require scribble/bnf "common.rkt")
@(require scribble/bnf
racket/runtime-path
(for-label wxme)
"common.rkt")
@title[#:tag "snip-example"]{Implementing New Snips}
@ -96,71 +99,25 @@ circle. Clicking on the snip causes the circle to grow. To enable
copying an instance of the snip from one program/eventspace to
another, the module should be @filepath{main.rkt} a
@filepath{circle-snip} directory that is installed as a
@filepath{circle-snip} package.
@filepath{circle-snip} package. The snip also has a @racketmodname[wxme]
reader implementation following it that must be installed as
the file @filepath{wxme-circle-snip.rkt} in the @filepath{circle-snip}
directory.
@codeblock{
#lang racket/base
(require racket/class
racket/snip
racket/format)
@(begin
(define-runtime-path snip-example.rkt "snip-example.rkt")
(define-runtime-path wxme-circle-snip.rkt "wxme-circle-snip.rkt")
(define (put-code filename)
(apply
typeset-code
#:context #'here
(call-with-input-file filename
(λ (port)
(for/list ([l (in-lines port)])
(format "~a\n" l))))))
(put-code snip-example.rkt))
(provide circle-snip%
(rename-out [circle-snip-class snip-class]))
This is the @filepath{wxme-circle-snip.rkt} file:
(define circle-snip%
(class snip%
(inherit set-snipclass
get-flags set-flags
get-admin)
(init-field [size 20.0])
@(put-code wxme-circle-snip.rkt))
(super-new)
(set-snipclass circle-snip-class)
(send (get-the-snip-class-list) add circle-snip-class)
(set-flags (cons 'handles-events (get-flags)))
(define/override (get-extent dc x y
[w #f]
[h #f]
[descent #f]
[space #f]
[lspace #f]
[rspace #f])
(define (maybe-set-box! b v) (when b (set-box! b v)))
(maybe-set-box! w (+ 2.0 size))
(maybe-set-box! h (+ 2.0 size))
(maybe-set-box! descent 1.0)
(maybe-set-box! space 1.0)
(maybe-set-box! lspace 1.0)
(maybe-set-box! rspace 1.0))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(send dc draw-ellipse (+ x 1.0) (+ y 1.0) size size))
(define/override (copy)
(new circle-snip% [size size]))
(define/override (write f)
(send f put size))
(define/override (on-event dc x y editorx editory e)
(when (send e button-down?)
(set! size (+ 1.0 size))
(define admin (get-admin))
(when admin
(send admin resized this #t))))))
(define circle-snip-class%
(class snip-class%
(inherit set-classname)
(super-new)
(set-classname (~s '(lib "main.rkt" "circle-snip")))
(define/override (read f)
(define size-b (box 0.0))
(send f get size-b)
(new circle-snip% [size (unbox size-b)]))))
(define circle-snip-class (new circle-snip-class%))
}

96
gui-doc/scribblings/gui/test-snip-example.rkt Normal file
View File

@ -0,0 +1,96 @@
#lang racket/base
(require wxme ;; this is dynamically required
racket/gui/base
racket/file
racket/runtime-path
racket/port)
(define collection-name "circle-snip")
(define snip-example-name "main.rkt")
(define-runtime-path snip-example.rkt "snip-example.rkt")
(define-runtime-path wxme-circle-snip.rkt "wxme-circle-snip.rkt")
(define new-lib-coll-dir
(make-temporary-file "scribblings-gui-test-snip-example-~a"
'directory))
(dynamic-wind
void
(λ ()
(make-directory (build-path new-lib-coll-dir collection-name))
(copy-file snip-example.rkt
(build-path new-lib-coll-dir collection-name snip-example-name))
(copy-file wxme-circle-snip.rkt
(build-path new-lib-coll-dir collection-name "wxme-circle-snip.rkt"))
(define orig-namespace (current-namespace))
(parameterize ([current-library-collection-paths
(cons new-lib-coll-dir
(current-library-collection-paths))])
(define save-filename (build-path new-lib-coll-dir collection-name "circle.rkt"))
(define circle-snip-pos #f)
(define (get-circle-snip-pos) circle-snip-pos)
(define (set-circle-snip-pos p) (set! circle-snip-pos p))
(parameterize ([current-namespace (make-base-namespace)])
(namespace-attach-module orig-namespace 'mred/mred)
(define circle-snip% (dynamic-require `(lib ,snip-example-name ,collection-name)
'circle-snip%))
(eval '(require racket/gui/base racket/class racket/format))
(eval
`(let ()
(define circle-snip% ,circle-snip%)
(define t (new text%))
(send t insert "#lang racket/base\n")
(send t insert "(define s ")
(,set-circle-snip-pos (send t last-position))
(send t insert (new circle-snip%))
(send t insert ")\n")
(send t insert (~s `(provide s)))
(send t save-file ,save-filename)
(send t set-filename #f)
(define t2 (new text%))
(send t2 set-filename ,save-filename)
(send t2 load-file)
(define circle-snip-copy (send t find-snip (,get-circle-snip-pos) 'after))
(unless (is-a? circle-snip-copy circle-snip%)
(error 'test-snip-example.rtk "didnt find circle snip.1, found ~s"
circle-snip-copy))
(define gui-loaded (dynamic-require ,save-filename 's))
(unless (is-a? gui-loaded circle-snip%)
(error 'test-snip-example.rkt "didnt find circle snip.2, found ~s"
gui-loaded)))))
(parameterize ([current-namespace (make-base-namespace)])
(define loaded (format "~s" (dynamic-require save-filename 's)))
(unless (regexp-match #rx"struct:object:circle-snip%" loaded)
(error 'test-snip-example.rkt "didn't find circle snip.3, found ~s" loaded)))
(define wxme-text-content
(parameterize ([current-namespace (make-base-namespace)])
(eval '(require racket/base wxme))
(eval
`(call-with-input-file ,save-filename
(λ (port)
(apply
string
(for/list ([s (in-input-port-chars (wxme-port->text-port port))])
s)))))))
(unless (regexp-match #rx"[(]circle [0-9.]+[)]" wxme-text-content)
(error 'test-snip-example.rkt "didn't find circle snip.4 ~s" wxme-text-content))
(define wxme-content-as-pos
(parameterize ([current-namespace (make-base-namespace)])
(eval '(require racket/base wxme))
(eval
`(call-with-input-file ,save-filename
(λ (port)
(port-count-lines! port)
(for/or ([s (in-port read-char-or-special
(wxme-port->port port))])
(and (syntax? s)
(list (syntax-position s)))))))))
(unless (equal? (list (+ circle-snip-pos 1)) wxme-content-as-pos)
(error 'test-snip-example.rkt "didn't find circle snip.5 ~s vs ~s"
wxme-content-as-pos
circle-snip-pos))))
(λ ()
(delete-directory/files new-lib-coll-dir)))

34
gui-doc/scribblings/gui/wxme-circle-snip.rkt Normal file
View File

@ -0,0 +1,34 @@
#lang racket/base
(require racket/class
racket/format
wxme
pict)
(provide reader)
(define circle-reader%
(class* object% (snip-reader<%>)
(define/public (read-header version stream) (void))
(define/public (read-snip text-only? version stream)
(define size (send stream read-inexact "circle-snip"))
(cond
[text-only?
(string->bytes/utf-8 (~s `(circle ,size)))]
[else
(new circle-readable [size size])]))
(super-new)))
(define circle-readable
(class* object% (readable<%>)
(init-field size)
(define/public (read-special source line column position)
;; construct a syntax object holding a 3d value that
;; is a circle from the pict library with an appropriate
;; source location
(datum->syntax #f
(circle size)
(vector source line column position 1)
#f))
(super-new)))
(define reader (new circle-reader%))