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

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

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:module-language-tools:tab-mixin
-   (drscheme:debug:test-coverage-tab-mixin
+   (drscheme:tracing:tab-mixin
-    (drscheme:debug:profile-tab-mixin
+    (drscheme:debug:test-coverage-tab-mixin
-     drscheme:unit:tab%))))
+     (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:module-language-tools:frame-mixin
-   (drscheme:debug:profile-unit-frame-mixin
+   (drscheme:tracing:frame-mixin
-    drscheme:unit:frame%)))
+    (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:module-language-tools:definitions-text-mixin
-   (drscheme:debug:profile-definitions-text-mixin
+   (drscheme:debug:test-coverage-definitions-text-mixin
-    (drscheme:unit:get-definitions-text%))))
+    (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%))

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@ 
+        language-configuration@ font@ module-language@ module-language-tools@
-        tracing@ app@
+        help-desk@ tracing@ app@
         main@))
 
 (define-unit/new-import-export drscheme@

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) '<<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)))
+
+|#

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))
     
 
@@ -1874,12 +1877,16 @@ module browser threading seems wrong.
             (begin-container-sequence)
             (show-info)
             
-            (let ([bpo (send button-panel get-orientation)])
+            ;; orient the button panel and all panels inside it.
-              (unless (equal? bpo (not vertical?))
+            (let loop ([obj button-panel])
-                (send button-panel set-orientation (not vertical?))
+              (when (is-a? obj area-container<%>)
-                
+                (when (or (is-a? obj vertical-panel%)
-                ;; have to be careful to avoid reversing the list when the orientation is already proper
+                          (is-a? obj horizontal-panel%))
-                (send button-panel change-children reverse)))
+                  (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)
             
@@ -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

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

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

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)

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

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