add an example tool (that actually does something) to the docs and make a test suite that sets that tool up and runs it

collects/meta/props

@@ -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 *)

collects/scribblings/tools/common.rkt

@@ -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)))
 

collects/scribblings/tools/example-src.rkt

@@ -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))))))

collects/scribblings/tools/tools.scrbl

@@ -1,20 +1,22 @@
 #lang scribble/doc
 @(begin
-(require scribble/manual
+   (require scribble/manual
-         "common.rkt"
+            "common.rkt"
-         (for-label racket/gui/base)
+            scribble/racket
-         (for-label drracket/tool-lib)
+            (for-syntax racket/base
-         (for-label racket/unit racket/contract racket/class)
+                        "example-src.rkt")
-         (for-label racket/base)
+            (for-label drracket/tool-lib)
-         (for-label framework/framework)
+            (for-label racket/unit racket/contract)
-         (for-label drracket/syncheck-drracket-button))
+            (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
+and the GUI library, as described in
-@(other-manual '(lib "scribblings/framework/framework.scrbl")).
+@(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, 
+Philippe Meunier, and
-Christian Queinnec,
+Christian Queinnec for their
-PLT at large, and many others for
+help being early clients for DrRacket plugins.
-their feedback and help.
 
-@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}
 

collects/setup/plt-single-installer.rkt

@@ -74,6 +74,8 @@
                       (make-info-domain #t)
                       (call-install #f)
                       (make-docs #f))
+                    
+                    (setup-program-name "raco setup")
 
                     (parallel-workers 1))
                   (invoke-unit

collects/tests/drracket/example-tool.rkt

@@ -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))

collects/tests/drracket/private/run-example-tool.rkt

@@ -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))))
+