diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index 4fbdeca163..88b8bf257e 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -4,6 +4,7 @@ (provide drscheme:eval^ drscheme:debug^ drscheme:module-language^ + drscheme:module-language-tools^ drscheme:get-collection^ drscheme:main^ drscheme:init^ @@ -84,6 +85,16 @@ (add-module-language module-language-put-file-mixin)) +(define-signature drscheme:module-langauge-tools-cm^ + (frame-mixin + frame<%> + tab-mixin + tab<%> + definitions-text-mixin + definitions-text<%>)) +(define-signature drscheme:module-language-tools^ extends drscheme:module-langauge-tools-cm^ + ()) + (define-signature drscheme:get-collection-cm^ ()) (define-signature drscheme:get-collection^ extends drscheme:get-collection-cm^ (get-file/collection)) diff --git a/collects/drscheme/private/get-extend.ss b/collects/drscheme/private/get-extend.ss index 58f20ea88a..d0d492fac7 100644 --- a/collects/drscheme/private/get-extend.ss +++ b/collects/drscheme/private/get-extend.ss @@ -7,7 +7,8 @@ [prefix drscheme:frame: drscheme:frame^] [prefix drscheme:rep: drscheme:rep^] [prefix drscheme:debug: drscheme:debug^] - [prefix drscheme:tracing: drscheme:tracing^]) + [prefix drscheme:tracing: drscheme:tracing^] + [prefix drscheme:module-language-tools: drscheme:module-language-tools^]) (export drscheme:get/extend^) (define make-extender @@ -44,10 +45,11 @@ built))))) (define (get-base-tab%) - (drscheme:tracing:tab-mixin - (drscheme:debug:test-coverage-tab-mixin - (drscheme:debug:profile-tab-mixin - drscheme:unit:tab%)))) + (drscheme:module-language-tools:tab-mixin + (drscheme:tracing:tab-mixin + (drscheme:debug:test-coverage-tab-mixin + (drscheme:debug:profile-tab-mixin + drscheme:unit:tab%))))) (define-values (extend-tab get-tab) (make-extender get-base-tab% 'tab%)) @@ -64,9 +66,10 @@ (make-extender get-base-definitions-canvas% 'definitions-canvas%)) (define (get-base-unit-frame%) - (drscheme:tracing:frame-mixin - (drscheme:debug:profile-unit-frame-mixin - drscheme:unit:frame%))) + (drscheme:module-language-tools:frame-mixin + (drscheme:tracing:frame-mixin + (drscheme:debug:profile-unit-frame-mixin + drscheme:unit:frame%)))) (define-values (extend-unit-frame get-unit-frame) (make-extender get-base-unit-frame% 'drscheme:unit:frame)) @@ -79,9 +82,10 @@ (make-extender get-base-interactions-text% 'interactions-text%)) (define (get-base-definitions-text%) - (drscheme:debug:test-coverage-definitions-text-mixin - (drscheme:debug:profile-definitions-text-mixin - (drscheme:unit:get-definitions-text%)))) + (drscheme:module-language-tools:definitions-text-mixin + (drscheme:debug:test-coverage-definitions-text-mixin + (drscheme:debug:profile-definitions-text-mixin + (drscheme:unit:get-definitions-text%))))) (define-values (extend-definitions-text get-definitions-text) (make-extender get-base-definitions-text% 'definitions-text%)) diff --git a/collects/drscheme/private/link.ss b/collects/drscheme/private/link.ss index 421dac2367..6bcc1ac41d 100644 --- a/collects/drscheme/private/link.ss +++ b/collects/drscheme/private/link.ss @@ -20,7 +20,8 @@ "unit.ss" "tracing.ss" "get-extend.ss" - "help-desk.ss") + "help-desk.ss" + "module-language-tools.ss") (provide drscheme@) @@ -39,8 +40,8 @@ drscheme:tracing^) (link init@ tools@ modes@ text@ eval@ frame@ rep@ language@ module-overview@ unit@ debug@ multi-file-search@ get-extend@ - language-configuration@ font@ module-language@ help-desk@ - tracing@ app@ + language-configuration@ font@ module-language@ module-language-tools@ + help-desk@ tracing@ app@ main@)) (define-unit/new-import-export drscheme@ diff --git a/collects/drscheme/private/module-language-tools.ss b/collects/drscheme/private/module-language-tools.ss new file mode 100644 index 0000000000..a5c4a3e203 --- /dev/null +++ b/collects/drscheme/private/module-language-tools.ss @@ -0,0 +1,223 @@ +#lang scheme/base +(provide module-language-tools@) +(require mrlib/switchable-button + mrlib/bitmap-label + scheme/contract + framework + scheme/unit + scheme/class + scheme/gui/base + "drsig.ss") + +(define-unit module-language-tools@ + (import [prefix drscheme:unit: drscheme:unit^] + [prefix drscheme:module-language: drscheme:module-language^] + [prefix drscheme:language: drscheme:language^] + [prefix drscheme:language-configuration: drscheme:language-configuration^]) + (export drscheme:module-language-tools^) + + (define-local-member-name initialized? move-to-new-language) + + (define tab<%> (interface ())) + + (define tab-mixin + (mixin (drscheme:unit:tab<%>) (tab<%>) + (inherit get-frame) + (define toolbar-buttons '()) + (define/public (get-lang-toolbar-buttons) toolbar-buttons) + (define/public (set-lang-toolbar-buttons bs) + (for-each + (λ (old-button) (send (get-frame) remove-toolbar-button old-button)) + toolbar-buttons) + (set! toolbar-buttons bs) + (send (get-frame) register-toolbar-buttons toolbar-buttons)) + (super-new))) + + (define frame<%> (interface ())) + (define frame-mixin + (mixin (drscheme:unit:frame<%>) (frame<%>) + (inherit unregister-toolbar-button get-definitions-text) + + (define toolbar-button-panel #f) + (define/public (initialized?) (and toolbar-button-panel #t)) + (define/public (get-toolbar-button-panel) toolbar-button-panel) + (define/public (remove-toolbar-button button) + (send toolbar-button-panel change-children (λ (l) (remq button l))) + (unregister-toolbar-button button)) + (define/augment (on-tab-change old-tab new-tab) + (inner (void) on-tab-change old-tab new-tab) + (when toolbar-button-panel + (send toolbar-button-panel change-children + (λ (l) (send new-tab get-lang-toolbar-buttons))))) + (super-new) + (inherit get-button-panel) + (set! toolbar-button-panel (new horizontal-panel% + [parent (get-button-panel)] + [stretchable-width #f])) + ;; move button panel to the front of the list + (send (get-button-panel) change-children + (λ (l) (cons toolbar-button-panel (remq toolbar-button-panel l)))) + (send (get-definitions-text) move-to-new-language))) + + (define definitions-text<%> (interface ())) + (define definitions-text-mixin + (mixin (text:basic<%> drscheme:unit:definitions-text<%>) (definitions-text<%>) + (inherit get-next-settings) + (define in-module-language? #f) ;; true when we are in the module language + (define hash-lang-last-location #f) ;; non-false when we know where the hash-lang line ended + (define hash-lang-language #f) ;; non-false is the string that was parsed for the language + (define/augment (after-insert start len) + (inner (void) after-insert start len) + (modification-at start)) + (define/augment (after-delete start len) + (inner (void) after-delete start len) + (modification-at start)) + (define/private (modification-at start) + (when (send (send (get-tab) get-frame) initialized?) + (when in-module-language? + (when (or (not hash-lang-last-location) + (<= start hash-lang-last-location)) + (move-to-new-language))))) + + (define/private (update-in-module-language? new-one) + (unless (equal? new-one in-module-language?) + (set! in-module-language? new-one) + (cond + [in-module-language? + (move-to-new-language)] + [else + (clear-things-out)]))) + + (define/public (move-to-new-language) + (let* ([port (open-input-text-editor this)] + [info-result (with-handlers ((exn:fail? (λ (x) #f))) + (read-language port (λ () #f)))]) + (let-values ([(line col pos) (port-next-location port)]) + (unless (equal? (get-text 0 pos) hash-lang-language) + (set! hash-lang-language (get-text 0 pos)) + (set! hash-lang-last-location pos) + (clear-things-out) + (when info-result + (register-new-buttons + (contract (or/c #f (listof (list/c string? + (is-a?/c bitmap%) + (-> (is-a?/c drscheme:unit:frame<%>) any)))) + (info-result 'drscheme:toolbar-buttons) + (get-lang-name pos) + 'drscheme/private/module-language-tools))))))) + + (inherit get-tab) + (define/private (register-new-buttons buttons) + (when buttons + (let* ([tab (get-tab)] + [frame (send tab get-frame)]) + (send tab set-lang-toolbar-buttons + (map (λ (button-spec) + (new switchable-button% + [label (list-ref button-spec 0)] + [bitmap (list-ref button-spec 1)] + [parent (send frame get-toolbar-button-panel)] + [callback + (lambda (button) + ((list-ref button-spec 2) frame))])) + buttons))))) + + (inherit get-text) + (define/private (get-lang-name pos) + (cond + [(zero? pos) '<>] + [else + (let ([str (get-text 0 pos)]) + (if (char-whitespace? (string-ref str (- (string-length str) 1))) + (substring str 0 (- (string-length str) 1)) + str))])) + + ;; removes language-specific customizations + (define/private (clear-things-out) + (send (get-tab) set-lang-toolbar-buttons '())) + + (define/augment (after-set-next-settings settings) + (update-in-module-language? + (is-a? (drscheme:language-configuration:language-settings-language settings) + drscheme:module-language:module-language<%>)) + (inner (void) after-set-next-settings settings)) + (super-new) + (set! in-module-language? + (is-a? (drscheme:language-configuration:language-settings-language (get-next-settings)) + drscheme:module-language:module-language<%>))))) + + + +#| + + + + + +#lang scheme/gui + +(require mrlib/switchable-button + mrlib/bitmap-label + drscheme/tool + scheme/system + setup/xref) + +(provide tool@) + +(define-namespace-anchor anchor) + +(define scribble-bm (make-object bitmap% 1 1)) + +(define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + (define phase1 void) + (define phase2 void) + + (define (make-new-unit-frame% super%) + (class super% + (inherit get-button-panel + get-definitions-text) + (super-instantiate ()) + + (define client-panel + (new horizontal-pane% (parent (get-button-panel)))) + + (define (make-render-button label mode suffix extra-cmdline) + (new switchable-button% + [label label] + [bitmap scribble-bm] + [parent client-panel] + [callback + (lambda (button) + (let* ([t (get-definitions-text)] + [fn (send t get-filename)]) + (if fn + (begin + (send t save-file) + (parameterize ([current-namespace (make-base-namespace)] + [current-command-line-arguments + (list->vector + (append + extra-cmdline + (list mode (if (path? fn) (path->string fn) fn))))]) + (namespace-attach-module (namespace-anchor->empty-namespace anchor) 'setup/xref) + (dynamic-require 'scribble/run #f) + (let-values ([(base name dir?) (split-path fn)]) + (system (format "open ~a" (path-replace-suffix name suffix)))))) + (message-box "Not Named" "Cannot render unsaved file"))))])) + + (inherit register-toolbar-button) + (define pdf-button (make-render-button "PDF" "--pdf" #".pdf" null)) + (register-toolbar-button pdf-button) + (define html-button (make-render-button "HTML" "--html" #".html" '("++xref-in" "setup/xref" "load-collections-xref"))) + (register-toolbar-button html-button) + + (send (get-button-panel) change-children + (lambda (l) (cons client-panel (remq client-panel l)))))) + + (drscheme:get/extend:extend-unit-frame make-new-unit-frame% #f))) + +|# \ No newline at end of file diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 56efd4e2e3..d685a2455d 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -62,6 +62,7 @@ module browser threading seems wrong. [prefix drscheme:eval: drscheme:eval^] [prefix drscheme:init: drscheme:init^] [prefix drscheme:module-language: drscheme:module-language^] + [prefix drscheme:module-language-tools: drscheme:module-language-tools^] [prefix drscheme:modes: drscheme:modes^] [prefix drscheme:debug: drscheme:debug^]) (export (rename drscheme:unit^ @@ -1399,6 +1400,8 @@ module browser threading seems wrong. get-language-menu register-toolbar-button + register-toolbar-buttons + unregister-toolbar-button get-tabs)) @@ -1868,19 +1871,23 @@ module browser threading seems wrong. (and (not (toolbar-is-hidden?)) (eq? (cdr (preferences:get 'drscheme:toolbar-state)) 'left))) - + (define/private (orient/show bar-at-beginning?) (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) (begin-container-sequence) (show-info) - (let ([bpo (send button-panel get-orientation)]) - (unless (equal? bpo (not vertical?)) - (send button-panel set-orientation (not vertical?)) - - ;; have to be careful to avoid reversing the list when the orientation is already proper - (send button-panel change-children reverse))) - + ;; orient the button panel and all panels inside it. + (let loop ([obj button-panel]) + (when (is-a? obj area-container<%>) + (when (or (is-a? obj vertical-panel%) + (is-a? obj horizontal-panel%)) + (unless (equal? (send obj get-orientation) (not vertical?)) + (send obj set-orientation (not vertical?)) + ;; have to be careful to avoid reversing the list when the orientation is already proper + (send obj change-children reverse))) + (for-each loop (send obj get-children)))) + (orient) (send top-outer-panel stretchable-height vertical?) @@ -1904,6 +1911,14 @@ module browser threading seems wrong. (set! toolbar-buttons (cons b toolbar-buttons)) (orient)) + (define/public (register-toolbar-buttons bs) + (set! toolbar-buttons (append bs toolbar-buttons)) + (orient)) + + (define/public (unregister-toolbar-button b) + (set! toolbar-buttons (remq b toolbar-buttons)) + (void)) + (define/private (orient) (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) (for-each diff --git a/collects/scribble/base/lang/reader.ss b/collects/scribble/base/lang/reader.ss index 1cbdf6c0f0..9152de7247 100644 --- a/collects/scribble/base/lang/reader.ss +++ b/collects/scribble/base/lang/reader.ss @@ -10,6 +10,9 @@ scribble/base/lang (case key [(color-lexer) (dynamic-require 'syntax-color/scribble-lexer 'scribble-inside-lexer)] + [(drscheme:toolbar-buttons) + (dynamic-require 'scribble/drscheme-buttons 'drscheme-buttons)] [else (default key)])) (require (prefix-in scribble: "../../reader.ss")) + diff --git a/collects/scribble/drscheme-buttons.ss b/collects/scribble/drscheme-buttons.ss new file mode 100644 index 0000000000..be73d47f3f --- /dev/null +++ b/collects/scribble/drscheme-buttons.ss @@ -0,0 +1,50 @@ +#lang scheme/base + +(require scheme/runtime-path + scheme/gui/base + scheme/class + mrlib/bitmap-label + scheme/system + setup/xref) + +(provide drscheme-buttons) + +(define-runtime-path pdf-png-path "pdf.png") +(define-runtime-path html-png-path "html.png") +(define pdf.png (make-object bitmap% pdf-png-path 'png/mask)) +(define html.png (make-object bitmap% html-png-path 'png/mask)) + +(define-namespace-anchor anchor) + +(define (make-render-button label bmp mode suffix extra-cmdline) + (list + label + bmp + (λ (drs-frame) + (let* ([t (send drs-frame get-definitions-text)] + [fn (send t get-filename)]) + (if (and fn (not (send t is-modified?))) + (let ([p (open-output-string)]) + (parameterize ([current-namespace (make-base-namespace)] + [current-output-port p] + [current-error-port p] + [current-command-line-arguments + (list->vector + (append + extra-cmdline + (list mode (if (path? fn) (path->string fn) fn))))]) + (namespace-attach-module (namespace-anchor->empty-namespace anchor) 'setup/xref) + (dynamic-require 'scribble/run #f) + (let-values ([(base name dir?) (split-path fn)]) + (system (format "open ~a" (path-replace-suffix name suffix))))) + (message-box "Scribble" (get-output-string p) drs-frame)) + (message-box "Not Named" "Cannot render unsaved file")))))) + +(define drscheme-buttons + (case (system-type) + [(macosx) + ;; really this is only to guard the "open" system call above. + (list (make-render-button "PDF" pdf.png "--pdf" #".pdf" null) + (make-render-button "HTML" html.png "--html" #".html" '("++xref-in" "setup/xref" "load-collections-xref")))] + [else + '()])) diff --git a/collects/scribble/html.png b/collects/scribble/html.png new file mode 100644 index 0000000000..ce3980b13b Binary files /dev/null and b/collects/scribble/html.png differ diff --git a/collects/scribble/pdf.png b/collects/scribble/pdf.png new file mode 100644 index 0000000000..8e88aac1c8 Binary files /dev/null and b/collects/scribble/pdf.png differ diff --git a/collects/scribble/private/mk-drs-bitmaps.ss b/collects/scribble/private/mk-drs-bitmaps.ss new file mode 100644 index 0000000000..0e5641d651 --- /dev/null +++ b/collects/scribble/private/mk-drs-bitmaps.ss @@ -0,0 +1,69 @@ +#lang scheme/gui + +(define width 16) +(define height 16) + +(define (draw1 dc color?) (draw dc "pdf" 0 7 color?)) +(define (draw2 dc color?) (draw dc "htm" -1 5 color?)) + +(define (draw dc str dx dy color?) + (send dc clear) + (send dc set-font (send the-font-list find-or-create-font 15 " Futura" 'swiss 'normal 'bold)) + (let-values ([(tw th _1 _2) (send dc get-text-extent "@")]) + (when color? (send dc set-text-foreground (send the-color-database find-color "gray"))) + (send dc draw-text "@" + (- (/ width 2) (/ tw 2)) + (- (/ height 2) (/ th 2))) + (send dc set-font (send the-font-list find-or-create-font 6 " Gill Sans" 'swiss 'normal 'bold)) + (when color? (send dc set-text-foreground (send the-color-database find-color "purple"))) + (send dc draw-text str (+ 0 dx) (- height dy) #f 0 (* pi 1/4)))) + +(define f (new frame% [label ""] [width 100] [height 100] [alignment '(center center)])) +(define c (new canvas% + [parent f] + [stretchable-width #f] + [stretchable-height #f] + [paint-callback (λ (c dc) (draw-bm dc pdf-bitmap))] + [min-width 16] + [min-height 16])) +(define c2 (new canvas% + [parent f] + [stretchable-width #f] + [stretchable-height #f] + [paint-callback (λ (c dc) (draw-bm dc html-bitmap))] + [min-width 16] + [min-height 16])) + + +(define (mk-bitmap draw) + (define mask-bm (make-object bitmap% width height)) + (define bm (make-object bitmap% width height)) + (define bdc (make-object bitmap-dc%)) + (send bm set-loaded-mask mask-bm) + (send bdc set-bitmap mask-bm) + (draw bdc #f) + (send bdc set-bitmap bm) + (draw bdc #t) + (send bdc set-bitmap #f) + bm) + +(define (draw-bm dc bm) + #;(send dc draw-bitmap (send bm get-loaded-mask) 0 0) + + (send dc set-pen "lightgray" 1 'transparent) + (send dc set-brush "lightgray" 'solid) + (send dc draw-rectangle 0 0 width height) + (send dc draw-bitmap bm 0 0 + 'solid + (send the-color-database find-color "black") + (send bm get-loaded-mask))) + + +(define pdf-bitmap (mk-bitmap draw1)) +(define html-bitmap (mk-bitmap draw2)) + +(begin + (send pdf-bitmap save-file "../pdf.png" 'png) + (send html-bitmap save-file "../html.png" 'png)) + +(send f show #t) diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index 7a76ea16a3..3a85850222 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(begin (require scribble/manual + (for-label scheme/gui/base) (for-label drscheme/tool-lib) (for-label scheme/unit) (for-label scheme/base) @@ -40,7 +41,6 @@ Cormac Flanagan, Matthew Flatt, Max Hailperin, Philippe Meunier, -and Christian Queinnec, PLT at large, and many others for their feedback and help. @@ -52,14 +52,9 @@ functionality. To extend the appearance or the functionality the DrScheme window (say, to annotate programs in certain ways, to add buttons to the DrScheme frame or to add additional languages to DrScheme) use a -tool. The Static Debugger, the Syntax Checker, the Stepper, +tool. The Macro Stepper, the Syntax Checker, the Stepper, and the teaching languages are all implemented as tools. -Libraries are for extensions of DrScheme that only want to -add new functions and other values bound in the users -namespace. See the DrScheme manual for more information on -constructing libraries. - When DrScheme starts up, it looks for tools by reading fields in the @File{info.ss} file of each collection and the newest version of each PLaneT package installed on the @@ -467,6 +462,23 @@ file based on the file's extension. If the file ends with @File{.txt}, DrScheme uses text mode. Otherwise, DrScheme uses Scheme mode. +@section{@tt{#lang}-specific tools} +@section-index["drscheme:toolbar-buttons"] + +If the result of @scheme[read-language] for a language is a function, +DrScheme will query it to determine if there are any new toolbar +buttons to be used when editing files in this language (when +DrScheme's language is set to the Module language). + +Specifically, DrScheme will pass @scheme['drscheme:toolbar-buttons] +to the function and expect back a value matching this contract: +@schemeblock[(listof (list/c string? + (is-a?/c bitmap%) + (-> (is-a?/c drscheme:unit:frame<%>) any)))] +which is then used to create new toolbar buttons, one for each list in the +first. The string is the label on the button; the bitmap is the icon (it should be 16x16), +and the function is called when the button is clicked. + @section{Language-specific capabilities} Drscheme's capability interface provides a mechanism for diff --git a/collects/scribblings/tools/unit.scrbl b/collects/scribblings/tools/unit.scrbl index b79139c286..10a6699d3d 100644 --- a/collects/scribblings/tools/unit.scrbl +++ b/collects/scribblings/tools/unit.scrbl @@ -684,6 +684,18 @@ Registers the toolbar button @scheme[tb]. This is required so that the toolbar buttons properly switch orientation when the toolbar's position is moved. } + +@defmethod[(register-toolbar-buttons [tbs (listof (is-a?/c switchable-button%))]) void?]{ +Simultaneously registers the toolbar buttons @scheme[tbs]. This is required +so that the toolbar buttons properly switch orientation when +the toolbar's position is moved. +} + +@defmethod[(unregister-toolbar-button [tb (is-a?/c switchable-button%)]) void?]{ +Unregisters the toolbar button @scheme[tb]. Use this method to ensure +that the button is not referenced by this frame and thus can be gc'd. +} + }