suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed PRs 7783 7785

Browse Source 
svn: r1731
This commit is contained in:
Robby Findler 2005-12-31 14:23:49 +00:00
parent d19819f305
commit 00d989a80a
19 changed files with 202 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/browser/doc.txt
View File

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

14
collects/browser/private/html.ss
View File

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

7
collects/browser/private/hyper.ss
View File

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

3
collects/drscheme/private/drsig.ss
View File

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

3
collects/drscheme/private/font.ss
View File

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

3
collects/drscheme/private/help-desk.ss
View File

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

3
collects/drscheme/private/link.ss
View File

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

4
collects/drscheme/private/main.ss
View File

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

2
collects/drscheme/private/rep.ss
View File

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

3
collects/framework/private/scheme.ss
View File

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

4
collects/framework/private/text.ss
View File

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

1
collects/help/help-desk.ss
View File

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

19
collects/help/help.ss
View File

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

6
collects/help/private/link.ss
View File

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

129
collects/help/private/main.ss
View File

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

6
collects/help/private/sig.ss
View File

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

7
collects/string-constants/english-string-constants.ss
View File

@ -305,6 +305,13 @@ 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")

3
collects/tests/mzscheme/net.ss
View File

@ -218,6 +218,9 @@
(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")
empty-url