fixed PRs 7783 7785

svn: r1731

collects/browser/doc.txt

@@ -104,13 +104,14 @@ The html-eval-ok parameter controls the evaluation of
 
 ----------------------------------------
 
-> (hyper-text-mixin text%) - Extends the given text% class. The
+> (hyper-text-mixin text%) - Extends the given text%
-   initialization arguments are extended with a four new first
+   class. The initialization arguments are extended with a
-   arguments: a url or a port to be loaded into the text% object, a
+   four new first arguments: a url or a port to be loaded
-   top-level-window or #f to use as a parent for status dialogs, a
+   into the text% object (using the `reload' method,
-   progress procedure used as for `get-url', and either #f or a post
+   described below), a top-level-window or #f to use as a
-   string to be sent to a web server (technically changing the GET to
+   parent for status dialogs, a progress procedure used as
-   a POST).
+   for `get-url', and either #f or a post string to be sent
+   to a web server (technically changing the GET to a POST).
 
    Sets the autowrap-bitmap to #f.
    
@@ -171,6 +172,9 @@ The html-eval-ok parameter controls the evaluation of
 
     Reloads the current page.
      
+    The text defaultly uses the basic style named "Html
+    Standard" in the editor (if it exists).
+
 >  remap-url :: (send o remap-url url) -> url or string or #f
 
    When visiting a new page, this method is called to remap
@@ -415,6 +419,10 @@ Reads HTML from `input-port' and renders it to `html-text<%>-obj'.  If
 `eval-mz?' is false, then MZSCHEME hyperlink expressions and comments
 are not evaluated.
 
+Uses the style named "Html Standard" in the editor's
+style-list (if it exists) for all of the inserted text's
+default style. 
+
 ========================================
 _external.ss_
 ========================================

collects/browser/private/html.ss

@@ -549,9 +549,19 @@
               (letrec ([image-map-snips null]
                        [image-maps null]
                        
+                       [html-basic-style
+                        (let ([sl (send a-text get-style-list)])
+                          (or (send sl find-named-style "Html Standard")
+                              (send sl find-named-style "Standard")
+                              (send sl find-named-style "Basic")))]
+                       
+                       ;; inserts 
                        [insert 
-                        (lambda (what)
+                        (λ (what)
-                          (a-text-insert what (current-pos)))]
+                          (let ([pos-before (current-pos)])
+                            (a-text-insert what pos-before)
+                            (let ([pos-after (current-pos)])
+                              (change-style html-basic-style pos-before pos-after))))]
                        
                        [insert-newlines
                         (lambda (num forced-lines para-base)

collects/browser/private/hyper.ss

@@ -122,7 +122,7 @@ A test case:
             (send mult set 0 0 0)
             (send add set 0 0 255))
           
-          (define/override (get-keymaps) (cons hyper-keymap (super get-keymaps)))
+          (define/override (get-keymaps) (list* space-page-keymap hyper-keymap (super get-keymaps)))
           (define/public (get-hyper-keymap) hyper-keymap)
           
           (define/augment (after-set-position)
@@ -585,6 +585,10 @@ A test case:
         
       (define hyper-text% (hyper-text-mixin text:keymap%))
 
+      (define space-page-keymap (make-object keymap%))
+      (add-text-keymap-functions space-page-keymap)
+      (send space-page-keymap map-function "space" "next-page")
+      
       (define hyper-keymap (make-object keymap%))
       (send hyper-keymap add-function "rewind" 
             (lambda (txt evt)
@@ -622,7 +626,6 @@ A test case:
       (send hyper-keymap map-function "pageup" "previous-page")
       (send hyper-keymap map-function "wheeldown" "do-wheel")
       (send hyper-keymap map-function "pagedown" "next-page")
-      ; (send hyper-keymap map-function "space" "next-page")
       
       ;; call-with-hyper-panel : object ((is-a?/c hyper-panel<%>) -> void) -> void
       (define (call-with-hyper-panel text f)

collects/drscheme/private/drsig.ss

@@ -197,7 +197,8 @@
      goto-plt-license
      help-desk
      get-docs
-     open-url))
+     open-url
+     add-help-desk-font-prefs))
   
   (define-signature drscheme:language^
     (get-default-mixin

collects/drscheme/private/font.ss

@@ -20,7 +20,8 @@
       
       (define (setup-preferences)
         (preferences:add-panel
-         (list (string-constant font-prefs-panel-title))
+         (list (string-constant font-prefs-panel-title)
+               (string-constant drscheme))
          (λ (panel)
            (let* ([main (make-object vertical-panel% panel)]
 		  [min-size 1]

collects/drscheme/private/help-desk.ss

@@ -18,6 +18,9 @@
               [drscheme:language-configuration : drscheme:language-configuration/internal^]
               [drscheme:teachpack : drscheme:teachpack^])
       
+      (rename [-add-help-desk-font-prefs add-help-desk-font-prefs])
+      (define (-add-help-desk-font-prefs b) (add-help-desk-font-prefs b))
+      
       ;; : -> string
       (define (get-computer-language-info)
         (let* ([language/settings (preferences:get 

collects/drscheme/private/link.ss

@@ -62,7 +62,8 @@
             [main : () (main@ 
                         app unit get/extend language-configuration language teachpack
                         module-language tools debug frame font
-                        modes)])
+                        modes
+                        help-desk)])
       (export
        (unit teachpack drscheme:teachpack)
        (unit language-configuration drscheme:language-configuration)))))

collects/drscheme/private/main.ss

@@ -31,7 +31,8 @@
               [drscheme:debug : drscheme:debug^]
               [drscheme:frame : drscheme:frame^]
               [drscheme:font : drscheme:font^]
-              [drscheme:modes : drscheme:modes^])
+              [drscheme:modes : drscheme:modes^]
+              [drscheme:help-desk : drscheme:help-desk^])
 
       (application-file-handler
        (let ([default (application-file-handler)])
@@ -167,6 +168,7 @@
        drscheme:teachpack:unmarshall-teachpack-cache)
       
       (drscheme:font:setup-preferences)
+      (drscheme:help-desk:add-help-desk-font-prefs #t)
       (color-prefs:add-background-preferences-panel)
       (scheme:add-preferences-panel)
       (scheme:add-coloring-preferences-panel)

collects/drscheme/private/rep.ss

@@ -865,8 +865,6 @@ TODO
             (send context set-breakables #f #f)
             (send context enable-evaluation))
           
-          (inherit backward-containing-sexp)
-          
           (define/augment (submit-to-port? key) 
             (and prompt-position
                  (only-whitespace-after-insertion-point)

collects/framework/private/scheme.ss

@@ -162,7 +162,8 @@
       
       ;; split/collapse-text : (instanceof menu%) (instanceof editor<%>) (instanceof mouse-event%) -> void
       (define (split/collapse-text menu text event)
-        (when (is-a? text -text<%>)
+        (when (and (is-a? text -text<%>)
+                   (not (send text is-frozen?)))
           (let* ([on-it-box (box #f)]
                  [click-pos 
                   (call-with-values

collects/framework/private/text.ss

@@ -1434,7 +1434,9 @@ WARNING: printf is rebound in the body of the unit to always
                                                  (make-write-special-proc value-style)))
               (let ([install-handlers
                      (λ (port)
-                       (set-interactive-print-handler port)
+                       ;; don't want to set the port-print-handler here; 
+                       ;; instead drscheme sets the global-port-print-handler
+                       ;; to catch fractions and the like
                        (set-interactive-write-handler port)
                        (set-interactive-display-handler port))])
                 (install-handlers out-port)

collects/help/help-desk.ss

@@ -12,6 +12,7 @@
   (provide help-desk-frame<%>)
   
   (provide/contract 
+   (add-help-desk-font-prefs (boolean? . -> . any))
    (set-bug-report-info! any/c)
    (find-doc-names (-> (listof (cons/c path? string?))))
    (goto-manual-link (string? string? . -> . any))

collects/help/help.ss

@@ -6,7 +6,7 @@ It is only loaded when Help Desk is run by itself (outside DrScheme).
 |#
 
 (module help mzscheme 
-  (require "bug-report.ss" ;; load now to init the preferences early
+  (require "bug-report.ss" ;; load now to init the preferences early enough
            (lib "cmdline.ss")
            (lib "class.ss")
            (lib "framework.ss" "framework")
@@ -19,22 +19,7 @@ It is only loaded when Help Desk is run by itself (outside DrScheme).
    "help-desk"
    (current-command-line-arguments))
   
-  (preferences:add-panel
+  (add-help-desk-font-prefs #f)
-   (list (string-constant font-prefs-panel-title))
-   (lambda (panel)
-     (let* ([hp (new horizontal-panel% (parent panel))]
-            [size (make-object slider% 
-                    (string-constant font-size)
-                    1
-                    72
-                    hp
-                    (lambda (size evt)
-                      (preferences:set 'framework:standard-style-list:font-size (send size get-value)))
-                    (preferences:get 'framework:standard-style-list:font-size))])
-       (preferences:add-callback
-        'framework:standard-style-list:font-size
-        (lambda (p v) (send size set-value v)))
-       hp)))
   (color-prefs:add-background-preferences-panel)
   (preferences:add-warnings-checkbox-panel)
   (install-help-browser-preference-panel)

collects/help/private/link.ss

@@ -40,11 +40,12 @@
        [browser : browser^ (browser@ plt-installer mred ic-tcp ic-url)]
        [gui : gui^ (gui@ browser ic-url)]
 
-       [m : () (main@)])
+       [main : main^ (main@)])
       (export (open gui)
+              (open main)
               (open web-server))))
   
-  (define-values/invoke-unit/sig ((open gui^) (open web-server^))
+  (define-values/invoke-unit/sig ((open gui^) (open web-server^) (open main^))
                                  help-desk@
                                  #f
                                  setup:plt-installer^
@@ -52,4 +53,5 @@
                                  net:tcp^)
   
   (provide-signature-elements gui^)
+  (provide-signature-elements main^)
   (provide-signature-elements web-server^))

collects/help/private/main.ss

@@ -6,12 +6,15 @@
            (lib "class.ss")
            (lib "external.ss" "browser")
            (lib "string-constant.ss" "string-constants")
+           (lib "xml.ss" "xml")
+           (lib "htmltext.ss" "browser")
+           (prefix home: "../servlets/home.ss")
            "sig.ss")
   
   (provide main@)
   
   (define main@
-    (unit/sig ()
+    (unit/sig main^
       (import)
       
       ;; where should the pref stuff really go?
@@ -24,6 +27,40 @@
       (preferences:set-default 'drscheme:help-desk:separate-browser #t boolean?)
       (preferences:set-default 'drscheme:help-desk:ask-about-external-urls #t boolean?)
       
+      (preferences:set-default 'drscheme:help-desk:font-size 
+                               (cons #f 
+                                     (let* ([txt (make-object text%)]
+                                            [stl (send txt get-style-list)]
+                                            [bcs (send stl basic-style)])
+                                       (send bcs get-size)))
+                               (λ (x) 
+                                 (and (pair? x)
+                                      (boolean? (car x))
+                                      (and (integer? (cdr x))
+                                           (<= 0 (cdr x) 255)))))
+      
+      ;; create "Html Standard" style to be able to
+      ;; adjust its size in the preferences dialog
+      (let* ([sl (editor:get-standard-style-list)]
+             [html-standard-style-delta (make-object style-delta% 'change-nothing)]
+             [html-standard-style 
+              (send sl find-or-create-style 
+                    (send sl find-named-style "Standard")
+                    html-standard-style-delta)])
+        (send sl new-named-style "Html Standard" html-standard-style))
+      
+      (preferences:add-callback
+       'drscheme:help-desk:font-size
+       (λ (k v) (update-font-size v)))
+      
+      (define (update-font-size v)
+        (let ([style (send (editor:get-standard-style-list) find-named-style "Html Standard")])
+          (send style set-delta
+                (if (car v)
+                    (make-object style-delta% 'change-size (cdr v))
+                    (make-object style-delta% 'change-nothing)))))
+      (update-font-size (preferences:get 'drscheme:help-desk:font-size))
+      
       (add-to-browser-prefs-panel
        (lambda (panel)
          (let* ([cbp (instantiate group-box-panel% ()
@@ -45,4 +82,92 @@
            (preferences:add-callback 
             'drscheme:help-desk:separate-browser
             (lambda (p v) (send cb set-value (not v))))
-           (void)))))))
+           (void))))
+      
+      (define (add-help-desk-font-prefs show-example?)
+        (preferences:add-panel
+         (list (string-constant font-prefs-panel-title) 
+               (string-constant help-desk))
+         (lambda (panel)
+           (let* ([vp (new vertical-panel% (parent panel) (alignment '(left top)))]
+                  [use-drs (new check-box%
+                                (label (string-constant use-drscheme-font-size))
+                                (parent vp)
+                                (value (not (car (preferences:get 'drscheme:help-desk:font-size))))
+                                (callback
+                                 (λ (cb y)
+                                   (preferences:set 'drscheme:help-desk:font-size 
+                                                    (cons (not (send cb get-value))
+                                                          (cdr (preferences:get
+                                                                'drscheme:help-desk:font-size)))))))]
+                  [size (new slider% 
+                             (label (string-constant font-size))
+                             (min-value 1)
+                             (max-value 255)
+                             (parent vp)
+                             (callback
+                              (λ (size evt)
+                                (preferences:set 'drscheme:help-desk:font-size
+                                                 (cons 
+                                                  #t
+                                                  (send size get-value)))))
+                             (init-value
+                              (cdr (preferences:get 'drscheme:help-desk:font-size))))]
+                  [hp (new horizontal-panel% 
+                           (alignment '(center center))
+                           (stretchable-height #f)
+                           (parent vp))]
+                  [mk-button
+                   (λ (label func)
+                     (new button% 
+                          (parent hp)
+                          (label label)
+                          (callback
+                           (λ (k v) 
+                             (let ([old (preferences:get 'drscheme:help-desk:font-size)])
+                               (preferences:set 'drscheme:help-desk:font-size 
+                                                (cons (car old) 
+                                                      (func (cdr old)))))))))]
+                  [sub1-button (mk-button "-1" sub1)]
+                  [add1-button (mk-button "+1" add1)]
+                  [enable/disable
+                   (λ (v)
+                     (send size enable (car v))
+                     (send sub1-button enable (car v))
+                     (send add1-button enable (car v))
+                     (send size set-value (cdr v)))])
+             (preferences:add-callback
+              'drscheme:help-desk:font-size 
+              (λ (k v)
+                (enable/disable v)))
+             (enable/disable (preferences:get 'drscheme:help-desk:font-size))
+             
+             (when show-example?
+               (let* ([show-message
+                       (λ ()
+                         (message-box 
+                          (string-constant help-desk)
+                          (string-constant help-desk-this-is-just-example-text)))]
+                      [mix
+                       (λ (%)
+                         (class %
+                           (inherit set-clickback)
+                           (define/override (add-link p1 p2 s)
+                             (set-clickback p1 p2 (lambda (e x y) (show-message))))
+                           (define/override (add-thunk-callback p1 p2 thunk)
+                             (set-clickback p1 p2 (lambda (e p1 p2) (show-message))))
+                           (define/override (add-scheme-callback p1 p2 scheme) 
+                             (set-clickback p1 p2 (lambda (e p1 p2) (show-message))))
+                           (super-new)))]
+                      [text (new (mix (html-text-mixin (text:hide-caret/selection-mixin 
+                                                        text:standard-style-list%))))]
+                      [msg (new message% (parent vp) (label (string-constant example-text)))]
+                      [ec (new editor-canvas% (parent vp) (editor text))])
+                 (let-values ([(in out) (make-pipe)])
+                   (thread
+                    (λ ()
+                      (write-xml/content (xexpr->xml (home:start #f)) out)
+                      (close-output-port out)))
+                   (render-html-to-text in text #f #t))))
+                    
+             vp)))))))

collects/help/private/sig.ss

@@ -1,6 +1,10 @@
 (module sig mzscheme
   (require (lib "unitsig.ss"))
-  (provide gui^)
+  (provide gui^
+           main^)
+  
+  (define-signature main^
+    (add-help-desk-font-prefs))
   
   (define-signature gui^
     (help-desk-frame<%>

collects/mrlib/interactive-value-port.ss

@@ -29,9 +29,9 @@
   
   (define (set-interactive-print-handler port)
     (port-print-handler
-     port
+      port
-     (λ (val port)
+      (λ (val port)
-       (do-printing pretty-print val port))))
+        (do-printing pretty-print val port))))
             
   (define (use-number-snip? x)
     (and #f

collects/string-constants/english-string-constants.ss

@@ -304,7 +304,14 @@ please adhere to these guidelines:
 
   ;; in the Help Desk language dialog, title on the right.
   (plt:hd:manual-search-ordering "Manual Search Order")
-
+  
+  ;; in the help-desk standalone font preference dialog, on a check box
+  (use-drscheme-font-size "Use DrScheme's font size")
+  
+  ;; in the preferences dialog in drscheme there is example text for help desk font size.
+  ;; clicking the links in that text produces a dialog with this message
+  (help-desk-this-is-just-example-text
+   "This is just example text for setting the font size. Open Help Desk proper (from Help menu) to follow these links.")
 
  ;; Help desk htty proxy
  (http-proxy "HTTP Proxy")

collects/tests/mzscheme/net.ss

@@ -217,6 +217,9 @@
              "http://www.drscheme.org/a ; a/ b / c ")
   (test-s->u (vector "http" "robb y" "www.drscheme.org" #f '("") '() #f)
              "http://robb%20y@www.drscheme.org/")
+
+  (test-s->u (vector "mailto" #f #f #f '("robby@plt-scheme.org") () #f)
+             "mailto:robby@plt-scheme.org")
   
   (let ([empty-url (make-url #f #f #f #f '() '() #f)])
     (test-c-u/r (string->url "http://www.drscheme.org")