added support for changing toolbar buttons based on the #lang line (when in the module language) and use that support for #lang scribble/base

svn: r16449
This commit is contained in:
Robby Findler 2009-10-29 16:01:40 +00:00
parent 2f47a882c9
commit be20c0747c
12 changed files with 429 additions and 29 deletions

View File

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

View File

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

View File

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

View File

@ -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) '<<unknown>>]
[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)))
|#

View File

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

View File

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

View File

@ -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
'()]))

BIN
collects/scribble/html.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 908 B

BIN
collects/scribble/pdf.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 858 B

View File

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

View File

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

View File

@ -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.
}
}