add an example tool (that actually does something) to the docs and make a test suite that sets that tool up and runs it
This commit is contained in:
Robby Findler
parent
422bf5eae7
commit
255cb84b87
|
|
@ -1415,6 +1415,7 @@ path/s is either such a string or a list of them.
|
|||
"collects/tests/deinprogramm/run-image-test.rkt" drdr:command-line (gracket-text "-t" *)
|
||||
"collects/tests/drracket" responsible (robby) drdr:random #t
|
||||
"collects/tests/drracket/drracket-test-util.rkt" drdr:command-line (gracket "-t" *)
|
||||
"collects/tests/drracket/example-tool.rkt" drdr:command-line (gracket "-t" *)
|
||||
"collects/tests/drracket/get-defs-test.rkt" drdr:command-line (gracket *)
|
||||
"collects/tests/drracket/hangman.rkt" responsible (robby matthias) drdr:command-line (gracket *)
|
||||
"collects/tests/drracket/io.rkt" drdr:command-line (gracket *)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang at-exp racket/base
|
||||
(require (for-syntax scheme/base))
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(require scribble/manual
|
||||
scribble/basic
|
||||
|
|
@ -17,7 +17,7 @@
|
|||
racket/class
|
||||
racket/contract
|
||||
racket/base
|
||||
drscheme/tool-lib
|
||||
drracket/tool-lib
|
||||
mrlib/switchable-button
|
||||
framework))
|
||||
(provide (for-label (all-from-out racket/gui/base)
|
||||
|
|
@ -25,7 +25,7 @@
|
|||
(all-from-out racket/class)
|
||||
(all-from-out racket/contract)
|
||||
(all-from-out racket/base)
|
||||
(all-from-out drscheme/tool-lib)
|
||||
(all-from-out drracket/tool-lib)
|
||||
(all-from-out mrlib/switchable-button)
|
||||
(all-from-out framework)))
|
||||
|
||||
|
|
|
|||
162
collects/scribblings/tools/example-src.rkt
Normal file
162
collects/scribblings/tools/example-src.rkt
Normal file
|
|
@ -0,0 +1,162 @@
|
|||
#lang racket/base
|
||||
(provide (struct-out src-wrap)
|
||||
files
|
||||
sexp-files)
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(define-struct src-wrap (obj srcloc)
|
||||
#:transparent)
|
||||
|
||||
(define-syntax (retain-src stx)
|
||||
|
||||
(define (to-src-wrap stx)
|
||||
(cond
|
||||
[(syntax? stx)
|
||||
#`(src-wrap #,(to-src-wrap (syntax-e stx))
|
||||
(vector '#,(syntax-source stx)
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
#,(syntax-position stx)
|
||||
#,(syntax-span stx)))]
|
||||
[(pair? stx)
|
||||
#`(cons #,(to-src-wrap (car stx))
|
||||
#,(to-src-wrap (cdr stx)))]
|
||||
[else
|
||||
#`'#,stx]))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(_ args ...)
|
||||
(with-syntax ([(args ...)
|
||||
(map to-src-wrap
|
||||
(syntax->list #'(args ...)))])
|
||||
#'(list args ...))]))
|
||||
|
||||
(define files
|
||||
(list (list "info.rkt"
|
||||
(retain-src
|
||||
setup/infotab
|
||||
(define drracket-tools (list (list "tool.rkt")))))
|
||||
(list "tool.rkt"
|
||||
(retain-src
|
||||
racket/base
|
||||
(require drracket/tool
|
||||
racket/class
|
||||
racket/gui/base
|
||||
racket/unit
|
||||
mrlib/switchable-button)
|
||||
(provide tool@)
|
||||
|
||||
(define secret-key "egg")
|
||||
(define to-insert "easter ")
|
||||
|
||||
(define tool@
|
||||
(unit
|
||||
(import drracket:tool^)
|
||||
(export drracket:tool-exports^)
|
||||
|
||||
(define easter-egg-mixin
|
||||
(mixin ((class->interface text%)) ()
|
||||
|
||||
(inherit begin-edit-sequence
|
||||
end-edit-sequence
|
||||
insert
|
||||
get-text)
|
||||
|
||||
(define/augment (on-insert start len)
|
||||
(begin-edit-sequence))
|
||||
(define/augment (after-insert start len)
|
||||
(check-range (max 0 (- start (string-length secret-key)))
|
||||
(+ start len))
|
||||
(end-edit-sequence))
|
||||
|
||||
(define/augment (on-delete start len)
|
||||
(begin-edit-sequence))
|
||||
(define/augment (after-delete start len)
|
||||
(check-range (max 0 (- start (string-length secret-key)))
|
||||
start)
|
||||
(end-edit-sequence))
|
||||
|
||||
(define/private (check-range start stop)
|
||||
(let/ec k
|
||||
(for ([x (in-range start stop)])
|
||||
(define after-x
|
||||
(get-text x (+ x (string-length secret-key))))
|
||||
(when (string=? after-x secret-key)
|
||||
(define before-x
|
||||
(get-text (max 0 (- x (string-length to-insert))) x))
|
||||
(unless (string=? before-x to-insert)
|
||||
(insert to-insert x x)
|
||||
(k (void)))))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define reverse-button-mixin
|
||||
(mixin (drracket:unit:frame<%>) ()
|
||||
(super-new)
|
||||
(inherit get-button-panel
|
||||
get-definitions-text)
|
||||
(inherit register-toolbar-button)
|
||||
|
||||
(let ([btn
|
||||
(new switchable-button%
|
||||
[label "Reverse Definitions"]
|
||||
[callback (λ (button)
|
||||
(reverse-content
|
||||
(get-definitions-text)))]
|
||||
[parent (get-button-panel)]
|
||||
[bitmap reverse-content-bitmap])])
|
||||
(register-toolbar-button btn)
|
||||
(send (get-button-panel) change-children
|
||||
(λ (l)
|
||||
(cons btn (remq btn l)))))))
|
||||
|
||||
(define reverse-content-bitmap
|
||||
(let* ([bmp (make-bitmap 16 16)]
|
||||
[bdc (make-object bitmap-dc% bmp)])
|
||||
(send bdc erase)
|
||||
(send bdc set-smoothing 'smoothed)
|
||||
(send bdc set-pen "black" 1 'transparent)
|
||||
(send bdc set-brush "blue" 'solid)
|
||||
(send bdc draw-ellipse 2 2 8 8)
|
||||
(send bdc set-brush "red" 'solid)
|
||||
(send bdc draw-ellipse 6 6 8 8)
|
||||
(send bdc set-bitmap #f)
|
||||
bmp))
|
||||
|
||||
(define (reverse-content text)
|
||||
(for ([x (in-range 1 (send text last-position))])
|
||||
(send text split-snip x))
|
||||
(define snips
|
||||
(let loop ([snip (send text find-first-snip)])
|
||||
(if snip
|
||||
(cons snip (loop (send snip next)))
|
||||
'())))
|
||||
(define released-snips
|
||||
(for/list ([snip (in-list snips)]
|
||||
#:when (send snip release-from-owner))
|
||||
snip))
|
||||
(for ([x (in-list released-snips)])
|
||||
(send text insert x 0 0)))
|
||||
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (void))
|
||||
|
||||
(drracket:get/extend:extend-definitions-text easter-egg-mixin)
|
||||
(drracket:get/extend:extend-unit-frame reverse-button-mixin)))))))
|
||||
|
||||
|
||||
(define (to-sexp x)
|
||||
(let loop ([sw x])
|
||||
(cond
|
||||
[(src-wrap? sw)
|
||||
(loop (src-wrap-obj sw))]
|
||||
[(pair? sw)
|
||||
(cons (loop (car sw)) (loop (cdr sw)))]
|
||||
[else sw])))
|
||||
|
||||
(define sexp-files
|
||||
(for/list ([file (in-list files)])
|
||||
(list (list-ref file 0)
|
||||
(to-sexp (car (list-ref file 1)))
|
||||
(to-sexp (cdr (list-ref file 1))))))
|
||||
|
|
@ -1,20 +1,22 @@
|
|||
#lang scribble/doc
|
||||
@(begin
|
||||
(require scribble/manual
|
||||
"common.rkt"
|
||||
(for-label racket/gui/base)
|
||||
(for-label drracket/tool-lib)
|
||||
(for-label racket/unit racket/contract racket/class)
|
||||
(for-label racket/base)
|
||||
(for-label framework/framework)
|
||||
(for-label drracket/syncheck-drracket-button))
|
||||
(require scribble/manual
|
||||
"common.rkt"
|
||||
scribble/racket
|
||||
(for-syntax racket/base
|
||||
"example-src.rkt")
|
||||
(for-label drracket/tool-lib)
|
||||
(for-label racket/unit racket/contract)
|
||||
(for-label racket/base racket/gui)
|
||||
(for-label framework/framework)
|
||||
(for-label drracket/syncheck-drracket-button))
|
||||
|
||||
(define (File x) @tt[x])
|
||||
(define (FileFirst x) @tt[x]) ;; indexing missing
|
||||
|
||||
(define-syntax-rule (item/cap x . ys)
|
||||
(item (indexed-racket x) ": " . ys))) ;; indexing missing
|
||||
|
||||
(define (File x) @tt[x])
|
||||
(define (FileFirst x) @tt[x]) ;; indexing missing
|
||||
|
||||
(define-syntax-rule (item/cap x . ys)
|
||||
(item (indexed-racket x) ": " . ys)) ;; indexing missing
|
||||
)
|
||||
|
||||
@title{@bold{Plugins}: Extending DrRacket}
|
||||
|
||||
|
|
@ -22,14 +24,19 @@
|
|||
|
||||
@defmodule*[(drracket/tool-lib drscheme/tool-lib)]
|
||||
|
||||
This manual describes DrRacket's tools interface. It assumes
|
||||
This manual describes DrRacket's plugins interface. It assumes
|
||||
familiarity with
|
||||
Racket, as described in
|
||||
Racket, as described in the
|
||||
@(other-manual '(lib "scribblings/guide/guide.scrbl")),
|
||||
and the
|
||||
@(other-manual '(lib "scribblings/reference/reference.scrbl")),
|
||||
DrRacket, as described in
|
||||
@(other-manual '(lib "scribblings/drracket/drracket.scrbl")),
|
||||
and the Framework, as described in
|
||||
@(other-manual '(lib "scribblings/framework/framework.scrbl")).
|
||||
and the GUI library, as described in
|
||||
@(other-manual '(lib "scribblings/gui/gui.scrbl")).
|
||||
The Framework, as described in
|
||||
@(other-manual '(lib "scribblings/framework/framework.scrbl")),
|
||||
may also come in handy.
|
||||
|
||||
The @racketmodname[drscheme/tool-lib] library is for backward
|
||||
compatibility; it exports all of the bindings of
|
||||
|
|
@ -39,21 +46,24 @@ compatibility; it exports all of the bindings of
|
|||
|
||||
@bold{Thanks}
|
||||
|
||||
Thanks especially to
|
||||
Thanks to PLT and the early adopters of the
|
||||
tools interface for
|
||||
their feedback and help.
|
||||
|
||||
A special thanks to
|
||||
Eli Barzilay,
|
||||
John Clements,
|
||||
Matthias Felleisen,
|
||||
Cormac Flanagan,
|
||||
Matthew Flatt,
|
||||
Max Hailperin,
|
||||
Philippe Meunier,
|
||||
Christian Queinnec,
|
||||
PLT at large, and many others for
|
||||
their feedback and help.
|
||||
Philippe Meunier, and
|
||||
Christian Queinnec for their
|
||||
help being early clients for DrRacket plugins.
|
||||
|
||||
@section[#:tag "implementing-tools"]{Implementing DrRacket Tools}
|
||||
@section[#:tag "implementing-tools"]{Implementing DrRacket Plugins}
|
||||
|
||||
Tools are designed for major extensions in DrRacket's
|
||||
Plugins are designed for major extensions in DrRacket's
|
||||
functionality. To extend the appearance
|
||||
or the functionality the DrRacket window (say, to annotate
|
||||
programs in certain ways, to add buttons to the DrRacket
|
||||
|
|
@ -183,6 +193,67 @@ This tool just opens a few windows to indicate that it has
|
|||
been loaded and that the @racket[phase1] and @racket[phase2]
|
||||
functions have been called.
|
||||
|
||||
Finally, here is a more involved example. This
|
||||
module defines a plugin that adds a button to the DrRacket
|
||||
frame that, when clicked, reverses the contents of the definitions
|
||||
window. It also adds an easter egg. Whenever the definitions text is
|
||||
modified, it checks to see if the definitions text contains the
|
||||
text ``egg''. If so, it adds ``easter '' just before.
|
||||
|
||||
@(let ()
|
||||
|
||||
(define-syntax-rule (define-linked-method name interface)
|
||||
(define-syntax name
|
||||
(make-element-id-transformer
|
||||
(lambda (stx)
|
||||
#'(method interface name)))))
|
||||
|
||||
(define-linked-method begin-edit-sequence editor<%>)
|
||||
(define-linked-method end-edit-sequence editor<%>)
|
||||
(define-linked-method find-first-snip editor<%>)
|
||||
(define-linked-method on-insert text%)
|
||||
(define-linked-method on-delete text%)
|
||||
(define-linked-method after-insert text%)
|
||||
(define-linked-method after-delete text%)
|
||||
|
||||
(define-linked-method insert text%)
|
||||
(define-linked-method get-text text%)
|
||||
(define-linked-method split-snip text%)
|
||||
|
||||
(define-linked-method next snip%)
|
||||
(define-linked-method release-from-owner snip%)
|
||||
|
||||
(define-linked-method change-children area-container<%>)
|
||||
|
||||
(define-linked-method get-button-panel drracket:unit:frame%)
|
||||
(define-linked-method register-toolbar-button drracket:unit:frame<%>)
|
||||
(define-linked-method get-definitions-text drracket:unit:frame<%>)
|
||||
|
||||
(define-linked-method erase dc<%>)
|
||||
(define-linked-method set-smoothing dc<%>)
|
||||
(define-linked-method set-pen dc<%>)
|
||||
(define-linked-method set-brush dc<%>)
|
||||
(define-linked-method draw-ellipse dc<%>)
|
||||
(define-linked-method set-bitmap bdc%)
|
||||
|
||||
(define-syntax (get-src stx)
|
||||
(define file (list-ref files 1))
|
||||
#`(racketmod
|
||||
#,@(let loop ([sw (list-ref file 1)])
|
||||
(cond
|
||||
[(src-wrap? sw)
|
||||
(datum->syntax #'here
|
||||
(loop (src-wrap-obj sw))
|
||||
(src-wrap-srcloc sw))]
|
||||
[(pair? sw)
|
||||
(cons (loop (car sw)) (loop (cdr sw)))]
|
||||
[else
|
||||
sw]))))
|
||||
|
||||
(get-src))
|
||||
|
||||
|
||||
|
||||
@section[#:tag "adding-languages"]{Adding Languages to DrRacket}
|
||||
@index{adding languages to DrRacket}
|
||||
|
||||
|
|
|
|||
|
|
@ -74,6 +74,8 @@
|
|||
(make-info-domain #t)
|
||||
(call-install #f)
|
||||
(make-docs #f))
|
||||
|
||||
(setup-program-name "raco setup")
|
||||
|
||||
(parallel-workers 1))
|
||||
(invoke-unit
|
||||
|
|
|
|||
30
collects/tests/drracket/example-tool.rkt
Normal file
30
collects/tests/drracket/example-tool.rkt
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
#lang racket/base
|
||||
(require "drracket-test-util.rkt"
|
||||
scribblings/tools/example-src
|
||||
racket/unit
|
||||
racket/gui/base)
|
||||
|
||||
(define new-collection-root
|
||||
(string->path "C:\\tmp")
|
||||
#;(make-temporary-file "drracket-test-example-tool~a"
|
||||
'directory))
|
||||
(define coll (build-path new-collection-root "coll"))
|
||||
(unless (directory-exists? coll) (make-directory coll))
|
||||
|
||||
(for ([f (in-list sexp-files)])
|
||||
(define fn (list-ref f 0))
|
||||
(define lang-line (format "#lang ~a" (list-ref f 1)))
|
||||
(define sexps (list-ref f 2))
|
||||
(call-with-output-file (build-path coll fn)
|
||||
(λ (port)
|
||||
(fprintf port "~a\n" lang-line)
|
||||
(for ([x (in-list sexps)])
|
||||
(fprintf port "~s\n" x)))
|
||||
#:exists 'truncate))
|
||||
|
||||
(parameterize ([current-namespace (make-gui-namespace)]
|
||||
[current-library-collection-paths
|
||||
(cons
|
||||
new-collection-root
|
||||
(current-library-collection-paths))])
|
||||
(namespace-require 'tests/drracket/private/run-example-tool))
|
||||
80
collects/tests/drracket/private/run-example-tool.rkt
Normal file
80
collects/tests/drracket/private/run-example-tool.rkt
Normal file
|
|
@ -0,0 +1,80 @@
|
|||
#lang racket/base
|
||||
(require "../drracket-test-util.rkt"
|
||||
setup/setup-unit
|
||||
setup/option-sig
|
||||
setup/option-unit
|
||||
launcher/launcher-unit
|
||||
launcher/launcher-sig
|
||||
compiler/sig
|
||||
compiler/compiler-unit
|
||||
compiler/option-unit
|
||||
dynext/compile-sig
|
||||
dynext/compile-unit
|
||||
dynext/link-sig
|
||||
dynext/link-unit
|
||||
dynext/file-sig
|
||||
dynext/file-unit
|
||||
racket/unit
|
||||
racket/gui/base
|
||||
racket/class
|
||||
framework/test
|
||||
mrlib/switchable-button)
|
||||
|
||||
(define init-options@
|
||||
(unit (import setup-option^)
|
||||
(export)
|
||||
(make-zo #f)
|
||||
(make-launchers #f)
|
||||
(make-docs #f)
|
||||
(call-install #f)
|
||||
(call-post-install #f)
|
||||
(setup-program-name "raco setup")
|
||||
(specific-collections '(("coll")))))
|
||||
|
||||
(let ([c (make-custodian)])
|
||||
(parameterize ([current-custodian c]
|
||||
[exit-handler
|
||||
(λ (x)
|
||||
(custodian-shutdown-all c))])
|
||||
(invoke-unit
|
||||
(compound-unit
|
||||
(import)
|
||||
(export)
|
||||
(link
|
||||
[((OPTIONS : setup-option^)) setup:option@]
|
||||
[() init-options@ OPTIONS]
|
||||
[((LAUNCHER : launcher^)) launcher@]
|
||||
[((COMPILER-OPTION : compiler:option^)) compiler:option@]
|
||||
[((DYNEXT-COMPILE : dynext:compile^)) dynext:compile@]
|
||||
[((DYNEXT-FILE : dynext:file^)) dynext:file@]
|
||||
[((DYNEXT-LINK : dynext:link^)) dynext:link@]
|
||||
[((COMPILER : compiler^)) compiler@ COMPILER-OPTION DYNEXT-FILE DYNEXT-COMPILE DYNEXT-LINK]
|
||||
[() setup@ LAUNCHER OPTIONS COMPILER-OPTION COMPILER DYNEXT-FILE])))))
|
||||
|
||||
(fire-up-drscheme-and-run-tests
|
||||
(λ ()
|
||||
(define drs (wait-for-drscheme-frame))
|
||||
(queue-callback/res (λ () (send (send drs get-definitions-canvas) focus)))
|
||||
(for ([x (in-string "egg\r1\r2\r3")])
|
||||
;; need #\r to actually get newlines in the editor
|
||||
;; see test:keystroke docs
|
||||
(test:keystroke x))
|
||||
|
||||
(queue-callback/res
|
||||
(λ ()
|
||||
(define btn
|
||||
(for/or ([x (in-list (send (send drs get-button-panel) get-children))])
|
||||
(and (is-a? x switchable-button%)
|
||||
(equal? (send x get-button-label) "Reverse Definitions")
|
||||
x)))
|
||||
(send btn command)))
|
||||
|
||||
(define content
|
||||
(queue-callback/res (λ () (send (send drs get-definitions-text) get-text))))
|
||||
(define expected (apply string (reverse (string->list "easter egg\n1\n2\n3"))))
|
||||
(unless (equal? content expected)
|
||||
(fprintf (current-error-port)
|
||||
"example-tool.rkt: test failed;\nexpected ~s\n but got ~s"
|
||||
expected
|
||||
content))))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user