diff --git a/collects/browser/doc.txt b/collects/browser/doc.txt index 58fd409fa3..4dcfc81587 100644 --- a/collects/browser/doc.txt +++ b/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 - initialization arguments are extended with a four new first - arguments: a url or a port to be loaded into the text% object, a - top-level-window or #f to use as a parent for status dialogs, a - progress procedure used as for `get-url', and either #f or a post - string to be sent to a web server (technically changing the GET to - a POST). +> (hyper-text-mixin text%) - Extends the given text% + class. The initialization arguments are extended with a + four new first arguments: a url or a port to be loaded + into the text% object (using the `reload' method, + described below), a top-level-window or #f to use as a + parent for status dialogs, a progress procedure used as + 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_ ======================================== diff --git a/collects/browser/private/html.ss b/collects/browser/private/html.ss index 6930016048..e60f07dac1 100644 --- a/collects/browser/private/html.ss +++ b/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) - (a-text-insert what (current-pos)))] + (λ (what) + (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) diff --git a/collects/browser/private/hyper.ss b/collects/browser/private/hyper.ss index 074093fd76..9b08697b98 100644 --- a/collects/browser/private/hyper.ss +++ b/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) diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index f745bd654f..7b9d1c7914 100644 --- a/collects/drscheme/private/drsig.ss +++ b/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 diff --git a/collects/drscheme/private/font.ss b/collects/drscheme/private/font.ss index 99c2f1b2d4..4128322831 100644 --- a/collects/drscheme/private/font.ss +++ b/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] diff --git a/collects/drscheme/private/help-desk.ss b/collects/drscheme/private/help-desk.ss index d42219fffc..b7049840cc 100644 --- a/collects/drscheme/private/help-desk.ss +++ b/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 diff --git a/collects/drscheme/private/link.ss b/collects/drscheme/private/link.ss index 229f9d450c..855b9d397c 100644 --- a/collects/drscheme/private/link.ss +++ b/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))))) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 8aae53466e..cd7cea7ad6 100644 --- a/collects/drscheme/private/main.ss +++ b/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) diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index b796429836..a22b117f62 100644 --- a/collects/drscheme/private/rep.ss +++ b/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) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index c2f1d04c94..5c6e3ec9f9 100644 --- a/collects/framework/private/scheme.ss +++ b/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 diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 82094f949b..123f2df8c9 100644 --- a/collects/framework/private/text.ss +++ b/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) diff --git a/collects/help/help-desk.ss b/collects/help/help-desk.ss index 16e5547344..ca6231db38 100644 --- a/collects/help/help-desk.ss +++ b/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)) diff --git a/collects/help/help.ss b/collects/help/help.ss index 976bb8df58..fddcf11e3d 100644 --- a/collects/help/help.ss +++ b/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 - (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))) + (add-help-desk-font-prefs #f) (color-prefs:add-background-preferences-panel) (preferences:add-warnings-checkbox-panel) (install-help-browser-preference-panel) diff --git a/collects/help/private/link.ss b/collects/help/private/link.ss index 4637f65378..c5b5b0da00 100644 --- a/collects/help/private/link.ss +++ b/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^)) \ No newline at end of file diff --git a/collects/help/private/main.ss b/collects/help/private/main.ss index 1cde9de977..b578b61850 100644 --- a/collects/help/private/main.ss +++ b/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))))))) \ No newline at end of file + (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))))))) \ No newline at end of file diff --git a/collects/help/private/sig.ss b/collects/help/private/sig.ss index 9dd4110207..e2a86c8c18 100644 --- a/collects/help/private/sig.ss +++ b/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<%> diff --git a/collects/mrlib/interactive-value-port.ss b/collects/mrlib/interactive-value-port.ss index 1808171ce2..e1c7eceb50 100644 --- a/collects/mrlib/interactive-value-port.ss +++ b/collects/mrlib/interactive-value-port.ss @@ -29,9 +29,9 @@ (define (set-interactive-print-handler port) (port-print-handler - port - (λ (val port) - (do-printing pretty-print val port)))) + port + (λ (val port) + (do-printing pretty-print val port)))) (define (use-number-snip? x) (and #f diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index bba071467f..db43c78639 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/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") diff --git a/collects/tests/mzscheme/net.ss b/collects/tests/mzscheme/net.ss index 9b2a482430..e29af77c18 100644 --- a/collects/tests/mzscheme/net.ss +++ b/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")