diff --git a/collects/meta/props b/collects/meta/props index 2a3e32e5f1..c887447747 100755 --- a/collects/meta/props +++ b/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 *) diff --git a/collects/scribblings/tools/common.rkt b/collects/scribblings/tools/common.rkt index a28a187f80..137c1cab40 100644 --- a/collects/scribblings/tools/common.rkt +++ b/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))) diff --git a/collects/scribblings/tools/example-src.rkt b/collects/scribblings/tools/example-src.rkt new file mode 100644 index 0000000000..9cc9108b8d --- /dev/null +++ b/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)))))) diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index e6881fe467..c3bb91b7d3 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -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} diff --git a/collects/setup/plt-single-installer.rkt b/collects/setup/plt-single-installer.rkt index dbce6412e2..6cdb328dde 100644 --- a/collects/setup/plt-single-installer.rkt +++ b/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 diff --git a/collects/tests/drracket/example-tool.rkt b/collects/tests/drracket/example-tool.rkt new file mode 100644 index 0000000000..bb3bcd60ed --- /dev/null +++ b/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)) diff --git a/collects/tests/drracket/private/run-example-tool.rkt b/collects/tests/drracket/private/run-example-tool.rkt new file mode 100644 index 0000000000..b434854f19 --- /dev/null +++ b/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)))) +