From 2f2bbd09cc388ab40dc90c4273d70e61ad71047d Mon Sep 17 00:00:00 2001 From: Patrick Mahoney Date: Sat, 23 Feb 2013 00:47:18 -0500 Subject: [PATCH] Browser-to-Racket Update the browser collection to use Racket lang instead of mzscheme. --- pkgs/drracket/browser/browser-sig.rkt | 18 +- pkgs/drracket/browser/browser-unit.rkt | 67 ++- pkgs/drracket/browser/browser.rkt | 30 +- pkgs/drracket/browser/browser.scrbl | 28 +- pkgs/drracket/browser/bullet-snip.rkt | 6 +- pkgs/drracket/browser/external.rkt | 2 +- pkgs/drracket/browser/htmltext.rkt | 143 +++-- pkgs/drracket/browser/info.rkt | 5 +- pkgs/drracket/browser/main.rkt | 2 +- pkgs/drracket/browser/private/btree.rkt | 10 +- pkgs/drracket/browser/private/bullet.rkt | 182 +++---- .../drracket/browser/private/entity-names.rkt | 514 +++++++++--------- pkgs/drracket/browser/private/html.rkt | 74 +-- pkgs/drracket/browser/private/hyper.rkt | 69 ++- pkgs/drracket/browser/private/option-snip.rkt | 384 +++++++------ pkgs/drracket/browser/private/sig.rkt | 112 ++-- pkgs/drracket/browser/tool.rkt | 29 +- .../private/danish-string-constants.rkt | 1 + .../private/dutch-string-constants.rkt | 1 + .../private/english-string-constants.rkt | 1 + .../private/french-string-constants.rkt | 1 + .../private/german-string-constants.rkt | 1 + .../private/japanese-string-constants.rkt | 1 + .../private/korean-string-constants.rkt | 1 + .../private/portuguese-string-constants.rkt | 1 + .../private/russian-string-constants.rkt | 1 + .../simplified-chinese-string-constants.rkt | 1 + .../private/spanish-string-constants.rkt | 1 + .../traditional-chinese-string-constants.rkt | 2 + .../private/ukrainian-string-constants.rkt | 1 + 30 files changed, 846 insertions(+), 843 deletions(-) diff --git a/pkgs/drracket/browser/browser-sig.rkt b/pkgs/drracket/browser/browser-sig.rkt index f34f09d7c9..c8ebc91d00 100644 --- a/pkgs/drracket/browser/browser-sig.rkt +++ b/pkgs/drracket/browser/browser-sig.rkt @@ -1,10 +1,10 @@ -(module browser-sig mzscheme - (require mzlib/unit - "private/sig.rkt") +#lang racket +(require racket/unit + "private/sig.rkt") - (provide browser^) - - (define-signature browser^ - ((open hyper^) - (open html-export^) - (open bullet-export^)))) +(provide browser^) + +(define-signature browser^ + ((open hyper^) + (open html-export^) + (open bullet-export^))) diff --git a/pkgs/drracket/browser/browser-unit.rkt b/pkgs/drracket/browser/browser-unit.rkt index efc05dd3fe..74de985909 100644 --- a/pkgs/drracket/browser/browser-unit.rkt +++ b/pkgs/drracket/browser/browser-unit.rkt @@ -1,38 +1,35 @@ -(module browser-unit mzscheme - (require mzlib/unit - mred/mred-sig - setup/plt-installer-sig - net/tcp-sig - net/url-sig - net/url-unit - "browser-sig.rkt" - "private/sig.rkt" - "private/bullet.rkt" - "private/html.rkt" - "private/hyper.rkt") - - (provide browser@) - - (define-unit-from-context bullet@ bullet-export^) - - (define-compound-unit/infer pre-browser@ - (import setup:plt-installer^ - mred^ - url^) - (export hyper^ html-export^ bullet-export^) - (link html@ hyper@ bullet@)) - (define-unit/new-import-export browser@ - (import setup:plt-installer^ - mred^ - url^) - (export browser^) - ((hyper^ html-export^ bullet-export^) - pre-browser@ - setup:plt-installer^ - mred^ - url^))) +#lang racket/base +(require racket/unit + mred/mred-sig + setup/plt-installer-sig + net/tcp-sig + net/url-sig + net/url-unit + "browser-sig.rkt" + "private/bullet.rkt" + "private/html.rkt" + "private/hyper.rkt" + "private/sig.rkt") +(provide browser@) - - +(define-unit-from-context bullet@ bullet-export^) + +(define-compound-unit/infer pre-browser@ + (import setup:plt-installer^ + mred^ + url^) + (export hyper^ html-export^ bullet-export^) + (link html@ hyper@ bullet@)) + +(define-unit/new-import-export browser@ + (import setup:plt-installer^ + mred^ + url^) + (export browser^) + ((hyper^ html-export^ bullet-export^) + pre-browser@ + setup:plt-installer^ + mred^ + url^)) \ No newline at end of file diff --git a/pkgs/drracket/browser/browser.rkt b/pkgs/drracket/browser/browser.rkt index e587a0d269..0a86c066f7 100644 --- a/pkgs/drracket/browser/browser.rkt +++ b/pkgs/drracket/browser/browser.rkt @@ -1,15 +1,15 @@ -(module browser mzscheme - (require mzlib/unit - mred - mred/mred-sig - setup/plt-installer-sig - setup/plt-installer - net/tcp-sig - net/url-sig - net/url - "browser-sig.rkt" - "browser-unit.rkt") - - (provide-signature-elements browser^) - - (define-values/invoke-unit/infer browser@)) +#lang racket +(require racket/unit + racket/gui + mred/mred-sig + setup/plt-installer-sig + setup/plt-installer + net/tcp-sig + net/url-sig + net/url + "browser-sig.rkt" + "browser-unit.rkt") + +(provide-signature-elements browser^) + +(define-values/invoke-unit/infer browser@) diff --git a/pkgs/drracket/browser/browser.scrbl b/pkgs/drracket/browser/browser.scrbl index fd1b1deae9..c5b0b52d1a 100644 --- a/pkgs/drracket/browser/browser.scrbl +++ b/pkgs/drracket/browser/browser.scrbl @@ -36,7 +36,7 @@ launching an external browser (such as Firefox). @declare-exporting[browser/browser browser] The browser supports basic HTML commands, plus special Racket hyperlinks -of the form @litchar{...}. When the user clicks +of the form @litchar{...}. When the user clicks on such a link, the string @racket[sexpr] is parsed as a Racket program and evaluated. Since @racket[sexpr] is likely to contain Racket strings, and since escape characters are difficult for people to read, a @@ -44,7 +44,7 @@ strings, and since escape characters are difficult for people to read, a character before it is parsed. Thus, @verbatim[#:indent 2]{ - Nowhere + Nowhere } creates a ``Nowhere'' hyperlink, which executes the Racket program @@ -59,15 +59,15 @@ clicks on ``Nowhere,'' the result is a new page that says ``This goes nowhere.'' The browser also treats comment forms containing -@litchar{MZSCHEME=sexpr} specially. Whereas the -@litchar{...} form executes the expression when -the user clicks, the @litchar{MZSCHEME} expression in a comment is +@litchar{RACKET=sexpr} specially. Whereas the +@litchar{...} form executes the expression when +the user clicks, the @litchar{RACKET} expression in a comment is executed immediately during HTML rendering. If the result is a string, the comment is replaced in the input HTML stream with the content of the string. Thus, @verbatim[#:indent 2]{ - + } inserts the path of the current working directory into the containing @@ -77,10 +77,10 @@ return values are ignored. If the html file is being accessed as a @litchar{file:} url, the @racket[current-load-relative-directory] parameter is set to the -directory during the evaluation of the mzscheme code (in both +directory during the evaluation of the Racket code (in both examples). The Racket code is executed through @racket[eval]. -The @litchar{MZSCHEME} forms are disabled unless the web page is a +The @litchar{RACKET} forms are disabled unless the web page is a @litchar{file:} url that points into the @racket[doc] collection. @defproc[(open-url [url (or/c url? string? input-port?)]) (is-a?/c hyper-frame%)]{ @@ -94,7 +94,7 @@ The @litchar{MZSCHEME} forms are disabled unless the web page is a } @defboolparam[html-eval-ok ok?]{ - A parameter that determines whether @litchar{MZSCHEME=} tags are + A parameter that determines whether @litchar{RACKET=} tags are evaluated. } @@ -145,7 +145,7 @@ The @litchar{MZSCHEME} forms are disabled unless the web page is a @definterface[hyper-text<%> ()]{ @defmethod[(url-allows-evalling? [url (or/c port? url?)]) boolean?]{ - Determines if @litchar{MZSCHEME} annotations are actually evaluated, + Determines if @litchar{RACKET} annotations are actually evaluated, for a given url. } } @@ -244,8 +244,8 @@ The @litchar{MZSCHEME} forms are disabled unless the web page is a } @defmethod[(eval-racket-string [str string?]) any]{ - Called to handle the @litchar{...} tag and - @litchar{} comments (see above). Evaluates the + Called to handle the @litchar{...} tag and + @litchar{} comments (see above). Evaluates the string; if the result is a string, it is opened as an HTML page. } @@ -559,11 +559,11 @@ The @litchar{MZSCHEME} forms are disabled unless the web page is a @defproc[(render-html-to-text [in input-port?] [dest (is-a? html-text<%>)] [load-img? any/c] - [eval-mz? any/c]) + [eval-rkt? any/c]) void?]{ Reads HTML from @racket[in] and renders it to @racket[dest]. If @racket[load-img?] is @racket[#f], then images are rendered as Xed-out - boxes. If @racket[eval-mz?] is @racket[#f], then @litchar{MZSCHEME} + boxes. If @racket[eval-rkt?] is @racket[#f], then @litchar{RACKET} hyperlink expressions and comments are not evaluated. Uses the style named @racket["Html Standard"] in the editor's diff --git a/pkgs/drracket/browser/bullet-snip.rkt b/pkgs/drracket/browser/bullet-snip.rkt index b603e8c23d..2dd054e88d 100644 --- a/pkgs/drracket/browser/bullet-snip.rkt +++ b/pkgs/drracket/browser/bullet-snip.rkt @@ -1,3 +1,3 @@ -(module bullet-snip mzscheme - (require "private/bullet.rkt") - (provide (rename bullet-snip-class snip-class))) +#lang racket +(require "private/bullet.rkt") +(provide (rename-out (bullet-snip-class snip-class))) diff --git a/pkgs/drracket/browser/external.rkt b/pkgs/drracket/browser/external.rkt index 112b66efa2..2fba812991 100644 --- a/pkgs/drracket/browser/external.rkt +++ b/pkgs/drracket/browser/external.rkt @@ -1,6 +1,6 @@ #lang racket/base (require string-constants - mred + racket/gui racket/class racket/file racket/list diff --git a/pkgs/drracket/browser/htmltext.rkt b/pkgs/drracket/browser/htmltext.rkt index 55c23ebf98..90de05c436 100644 --- a/pkgs/drracket/browser/htmltext.rkt +++ b/pkgs/drracket/browser/htmltext.rkt @@ -1,77 +1,76 @@ +#lang racket +(require racket/unit + racket/class + "browser-sig.rkt" + "private/sig.rkt" + "private/html.rkt" + "private/bullet.rkt" + net/url + net/url-sig + racket/gui + mred/mred-unit + mred/mred-sig + browser/external) -(module htmltext mzscheme - (require mzlib/unit - mzlib/class - "browser-sig.rkt" - "private/sig.rkt" - "private/html.rkt" - "private/bullet.rkt" - net/url - net/url-sig - mred - mred/mred-unit - mred/mred-sig - browser/external) - - (define-unit-from-context url@ url^) - - (define-values/invoke-unit - (compound-unit/infer (import) (export html^) - (link standard-mred@ url@ html@)) - (import) - (export html^)) - - (define html-text<%> - (interface ((class->interface text%)) - get-url - set-title - add-link - add-tag - make-link-style - add-scheme-callback - add-thunk-callback - post-url)) +(define-unit-from-context url@ url^) - (define url-delta (make-object style-delta% 'change-underline #t)) - (send url-delta set-delta-foreground "blue") +(define-values/invoke-unit + (compound-unit/infer (import) (export html^) + (link standard-mred@ url@ html@)) + (import) + (export html^)) - (define html-text-mixin - (mixin ((class->interface text%)) (html-text<%>) - (inherit change-style set-clickback) - - (define/public (get-url) #f) - (define/public (set-title s) (void)) - (define/public (add-link pos end-pos url-string) - (set-clickback pos end-pos (lambda (e start-pos eou-pos) - (send-url url-string)))) - (define/public (add-tag label pos) (void)) - (define/public (make-link-style pos endpos) - (change-style url-delta pos endpos)) - (define/public (add-scheme-callback pos endpos scheme) (void)) - (define/public (add-thunk-callback pos endpos thunk) - (set-clickback pos endpos (lambda (e start-pos eou-pos) - (thunk)))) - (define/public (post-url url post-data) - (message-box "HTML" - (format "Cannot perform post: ~e" - post-data) - #f - '(stop ok))) - (super-new))) +(define html-text<%> + (interface ((class->interface text%)) + get-url + set-title + add-link + add-tag + make-link-style + add-racket-callback + add-thunk-callback + post-url)) - (define (render-html-to-text port text%-obj img-ok? eval-ok?) - (unless (input-port? port) - (raise-type-error 'render-html-to-text "input port" 0 (list port text%-obj))) - (unless (text%-obj . is-a? . html-text<%>) - (raise-type-error 'render-html-to-text "html-text<%> object" 0 (list port text%-obj))) - (parameterize ([html-eval-ok eval-ok?] - [html-img-ok img-ok?]) - (dynamic-wind - (lambda () (send text%-obj begin-edit-sequence #f)) - (lambda () (html-convert port text%-obj)) - (lambda () (send text%-obj end-edit-sequence))))) - - (provide html-text<%> - html-text-mixin - render-html-to-text)) +(define url-delta (make-object style-delta% 'change-underline #t)) +(send url-delta set-delta-foreground "blue") + +(define html-text-mixin + (mixin ((class->interface text%)) (html-text<%>) + (inherit change-style set-clickback) + + (define/public (get-url) #f) + (define/public (set-title s) (void)) + (define/public (add-link pos end-pos url-string) + (set-clickback pos end-pos (lambda (e start-pos eou-pos) + (send-url url-string)))) + (define/public (add-tag label pos) (void)) + (define/public (make-link-style pos endpos) + (change-style url-delta pos endpos)) + (define/public (add-racket-callback pos endpos racket) (void)) + (define/public (add-thunk-callback pos endpos thunk) + (set-clickback pos endpos (lambda (e start-pos eou-pos) + (thunk)))) + (define/public (post-url url post-data) + (message-box "HTML" + (format "Cannot perform post: ~e" + post-data) + #f + '(stop ok))) + (super-new))) + +(define (render-html-to-text port text%-obj img-ok? eval-ok?) + (unless (input-port? port) + (raise-type-error 'render-html-to-text "input port" 0 (list port text%-obj))) + (unless (text%-obj . is-a? . html-text<%>) + (raise-type-error 'render-html-to-text "html-text<%> object" 0 (list port text%-obj))) + (parameterize ([html-eval-ok eval-ok?] + [html-img-ok img-ok?]) + (dynamic-wind + (lambda () (send text%-obj begin-edit-sequence #f)) + (lambda () (html-convert port text%-obj)) + (lambda () (send text%-obj end-edit-sequence))))) + +(provide html-text<%> + html-text-mixin + render-html-to-text) diff --git a/pkgs/drracket/browser/info.rkt b/pkgs/drracket/browser/info.rkt index 4577879d80..3b4c8eb741 100644 --- a/pkgs/drracket/browser/info.rkt +++ b/pkgs/drracket/browser/info.rkt @@ -1,6 +1,5 @@ #lang setup/infotab -(define tools (list (list "tool.rkt"))) -(define tool-names (list "Browser")) - +(define drracket-tools (list (list "tool.rkt"))) +(define drracket-tool-names (list "Browser")) (define scribblings '(("browser.scrbl" () (gui-library)))) diff --git a/pkgs/drracket/browser/main.rkt b/pkgs/drracket/browser/main.rkt index b5d855492c..456451fdd1 100644 --- a/pkgs/drracket/browser/main.rkt +++ b/pkgs/drracket/browser/main.rkt @@ -1,3 +1,3 @@ -#lang scheme/base +#lang racket/base (require "browser.rkt") (provide (all-from-out "browser.rkt")) diff --git a/pkgs/drracket/browser/private/btree.rkt b/pkgs/drracket/browser/private/btree.rkt index daa4616447..07d08c5ae5 100644 --- a/pkgs/drracket/browser/private/btree.rkt +++ b/pkgs/drracket/browser/private/btree.rkt @@ -1,4 +1,4 @@ -#lang scheme/unit +#lang racket/unit (require "sig.rkt") @@ -12,9 +12,9 @@ (export (rename relative-btree^ (create-btree make-btree))) -(define-struct btree (root) #:mutable) +(struct btree (root) #:mutable) -(define-struct node (pos data parent left right color) #:mutable) +(struct node (pos data parent left right color) #:mutable) (define (adjust-offsets n new-child) (when new-child @@ -66,7 +66,7 @@ (define (insert before? n btree pos data) - (let ([new (make-node pos data #f #f #f 'black)]) + (let ([new (node pos data #f #f #f 'black)]) (if (not (btree-root btree)) (set-btree-root! btree new) @@ -166,7 +166,7 @@ (loop (node-right n) so-far so-far-pos npos)])))))) (define (create-btree) - (make-btree #f)) + (btree #f)) (define (btree-get btree pos) (let-values ([(n npos) (find-following-node btree pos)]) diff --git a/pkgs/drracket/browser/private/bullet.rkt b/pkgs/drracket/browser/private/bullet.rkt index 1f05c4492c..3ec5281980 100644 --- a/pkgs/drracket/browser/private/bullet.rkt +++ b/pkgs/drracket/browser/private/bullet.rkt @@ -1,94 +1,94 @@ -(module bullet mzscheme - (require mred - mzlib/class) - - (provide bullet-snip% - get-bullet-width - bullet-size - bullet-snip-class) - - (define snip-class-name "(lib \"bullet-snip.ss\" \"browser\")") +#lang racket +(require racket/gui + racket/class) - (define bullet-size - (make-parameter - (let ([s (send (send (send (make-object text%) get-style-list) basic-style) - get-size)]) - (max 7 (quotient s 2))))) - - (define (get-bullet-width) - (* 2 (bullet-size))) - - (define transparent-brush (send the-brush-list find-or-create-brush "WHITE" 'transparent)) - - (define bullet-snip% - (class snip% - (init-field depth) - (inherit set-snipclass set-count get-style) - (define bsize (bullet-size)) - (define/private (zero b) (when b (set-box! b 0))) - [define/private get-height - (lambda (dc) - (let ([s (get-style)]) - (max bsize (- (send s get-text-height dc) - (send s get-text-descent dc)))))] - - [define/override get-extent - (lambda (dc x y wbox hbox descentbox spacebox - lspacebox rspacebox) - (when hbox - (set-box! hbox (get-height dc))) - (when wbox - (set-box! wbox (* 2 bsize))) - (zero descentbox) - (zero spacebox) - (zero rspacebox) - (zero lspacebox))] - [define/override draw - (lambda (dc x y . other) - (let ([y (+ y (ceiling (/ (- (get-height dc) bsize) 2)))]) - (let-values ([(draw solid?) - (case depth - [(0) (values (lambda (x y w h) (send dc draw-ellipse x y w h)) #t)] - [(1) (values (lambda (x y w h) (send dc draw-ellipse x y w h)) #f)] - [else (values (lambda (x y w h) (send dc draw-rectangle x y w h)) #f)])]) - (let ([b (send dc get-brush)]) - (send dc set-brush - (if solid? - (send the-brush-list - find-or-create-brush - (send (send dc get-pen) get-color) - 'solid) - transparent-brush)) - (draw x y bsize bsize) - (send dc set-brush b)))))] - [define/override copy - (lambda () - (make-object bullet-snip% depth))] - [define/override write - (lambda (stream) - (send stream put depth))] - [define/override get-text - (lambda (offset num flattened?) - (if (< num 1) - "" - (if flattened? - "* " - "*")))] - (super-new) - (set-snipclass bullet-snip-class) - (set-count 1))) - - (define bullet-snip-class - (make-object - (class snip-class% - (inherit set-classname) - [define/override read - (lambda (stream) - (let ([d-box (box 0)]) - (send stream get d-box) - (make-object bullet-snip% (unbox d-box))))] - (super-new) - (set-classname snip-class-name)))) +(provide bullet-snip% + get-bullet-width + bullet-size + bullet-snip-class) - (send (get-the-snip-class-list) add bullet-snip-class)) +(define snip-class-name "(lib \"bullet-snip.rkt\" \"browser\")") + +(define bullet-size + (make-parameter + (let ([s (send (send (send (make-object text%) get-style-list) basic-style) + get-size)]) + (max 7 (quotient s 2))))) + +(define (get-bullet-width) + (* 2 (bullet-size))) + +(define transparent-brush (send the-brush-list find-or-create-brush "WHITE" 'transparent)) + +(define bullet-snip% + (class snip% + (init-field depth) + (inherit set-snipclass set-count get-style) + (define bsize (bullet-size)) + (define/private (zero b) (when b (set-box! b 0))) + [define/private get-height + (lambda (dc) + (let ([s (get-style)]) + (max bsize (- (send s get-text-height dc) + (send s get-text-descent dc)))))] + + [define/override get-extent + (lambda (dc x y wbox hbox descentbox spacebox + lspacebox rspacebox) + (when hbox + (set-box! hbox (get-height dc))) + (when wbox + (set-box! wbox (* 2 bsize))) + (zero descentbox) + (zero spacebox) + (zero rspacebox) + (zero lspacebox))] + [define/override draw + (lambda (dc x y . other) + (let ([y (+ y (ceiling (/ (- (get-height dc) bsize) 2)))]) + (let-values ([(draw solid?) + (case depth + [(0) (values (lambda (x y w h) (send dc draw-ellipse x y w h)) #t)] + [(1) (values (lambda (x y w h) (send dc draw-ellipse x y w h)) #f)] + [else (values (lambda (x y w h) (send dc draw-rectangle x y w h)) #f)])]) + (let ([b (send dc get-brush)]) + (send dc set-brush + (if solid? + (send the-brush-list + find-or-create-brush + (send (send dc get-pen) get-color) + 'solid) + transparent-brush)) + (draw x y bsize bsize) + (send dc set-brush b)))))] + [define/override copy + (lambda () + (make-object bullet-snip% depth))] + [define/override write + (lambda (stream) + (send stream put depth))] + [define/override get-text + (lambda (offset num flattened?) + (if (< num 1) + "" + (if flattened? + "* " + "*")))] + (super-new) + (set-snipclass bullet-snip-class) + (set-count 1))) + +(define bullet-snip-class + (make-object + (class snip-class% + (inherit set-classname) + [define/override read + (lambda (stream) + (let ([d-box (box 0)]) + (send stream get d-box) + (make-object bullet-snip% (unbox d-box))))] + (super-new) + (set-classname snip-class-name)))) + +(send (get-the-snip-class-list) add bullet-snip-class) diff --git a/pkgs/drracket/browser/private/entity-names.rkt b/pkgs/drracket/browser/private/entity-names.rkt index a1d5d82a7b..0095cff995 100644 --- a/pkgs/drracket/browser/private/entity-names.rkt +++ b/pkgs/drracket/browser/private/entity-names.rkt @@ -1,261 +1,261 @@ -(module entity-names mzscheme - (provide entity-name->integer) +#lang racket +(provide entity-name->integer) - (define table - #cs#hasheq((nbsp . 160) - (iexcl . 161) - (cent . 162) - (pound . 163) - (curren . 164) - (yen . 165) - (brvbar . 166) - (sect . 167) - (uml . 168) - (copy . 169) - (ordf . 170) - (laquo . 171) - (not . 172) - (shy . 173) - (reg . 174) - (macr . 175) - (deg . 176) - (plusmn . 177) - (sup2 . 178) - (sup3 . 179) - (acute . 180) - (micro . 181) - (para . 182) - (middot . 183) - (cedil . 184) - (sup1 . 185) - (ordm . 186) - (raquo . 187) - (frac14 . 188) - (frac12 . 189) - (frac34 . 190) - (iquest . 191) - (Agrave . 192) - (Aacute . 193) - (Acirc . 194) - (Atilde . 195) - (Auml . 196) - (Aring . 197) - (AElig . 198) - (Ccedil . 199) - (Egrave . 200) - (Eacute . 201) - (Ecirc . 202) - (Euml . 203) - (Igrave . 204) - (Iacute . 205) - (Icirc . 206) - (Iuml . 207) - (ETH . 208) - (Ntilde . 209) - (Ograve . 210) - (Oacute . 211) - (Ocirc . 212) - (Otilde . 213) - (Ouml . 214) - (times . 215) - (Oslash . 216) - (Ugrave . 217) - (Uacute . 218) - (Ucirc . 219) - (Uuml . 220) - (Yacute . 221) - (THORN . 222) - (szlig . 223) - (agrave . 224) - (aacute . 225) - (acirc . 226) - (atilde . 227) - (auml . 228) - (aring . 229) - (aelig . 230) - (ccedil . 231) - (egrave . 232) - (eacute . 233) - (ecirc . 234) - (euml . 235) - (igrave . 236) - (iacute . 237) - (icirc . 238) - (iuml . 239) - (eth . 240) - (ntilde . 241) - (ograve . 242) - (oacute . 243) - (ocirc . 244) - (otilde . 245) - (ouml . 246) - (divide . 247) - (oslash . 248) - (ugrave . 249) - (uacute . 250) - (ucirc . 251) - (uuml . 252) - (yacute . 253) - (thorn . 254) - (yuml . 255) - (fnof . 402) - (Alpha . 913) - (Beta . 914) - (Gamma . 915) - (Delta . 916) - (Epsilon . 917) - (Zeta . 918) - (Eta . 919) - (Theta . 920) - (Iota . 921) - (Kappa . 922) - (Lambda . 923) - (Mu . 924) - (Nu . 925) - (Xi . 926) - (Omicron . 927) - (Pi . 928) - (Rho . 929) - (Sigma . 931) - (Tau . 932) - (Upsilon . 933) - (Phi . 934) - (Chi . 935) - (Psi . 936) - (Omega . 937) - (alpha . 945) - (beta . 946) - (gamma . 947) - (delta . 948) - (epsilon . 949) - (zeta . 950) - (eta . 951) - (theta . 952) - (iota . 953) - (kappa . 954) - (lambda . 955) - (mu . 956) - (nu . 957) - (xi . 958) - (omicron . 959) - (pi . 960) - (rho . 961) - (sigmaf . 962) - (sigma . 963) - (tau . 964) - (upsilon . 965) - (phi . 966) - (chi . 967) - (psi . 968) - (omega . 969) - (thetasym . 977) - (upsih . 978) - (piv . 982) - (bull . 8226) - (hellip . 8230) - (prime . 8242) - (Prime . 8243) - (oline . 8254) - (frasl . 8260) - (weierp . 8472) - (image . 8465) - (real . 8476) - (trade . 8482) - (alefsym . 8501) - (larr . 8592) - (uarr . 8593) - (rarr . 8594) - (darr . 8595) - (harr . 8596) - (crarr . 8629) - (lArr . 8656) - (uArr . 8657) - (rArr . 8658) - (dArr . 8659) - (hArr . 8660) - (forall . 8704) - (part . 8706) - (exist . 8707) - (empty . 8709) - (nabla . 8711) - (isin . 8712) - (notin . 8713) - (ni . 8715) - (prod . 8719) - (sum . 8721) - (minus . 8722) - (lowast . 8727) - (radic . 8730) - (prop . 8733) - (infin . 8734) - (ang . 8736) - (and . 8743) - (or . 8744) - (cap . 8745) - (cup . 8746) - (int . 8747) - (there4 . 8756) - (sim . 8764) - (cong . 8773) - (asymp . 8776) - (ne . 8800) - (equiv . 8801) - (le . 8804) - (ge . 8805) - (sub . 8834) - (sup . 8835) - (nsub . 8836) - (sube . 8838) - (supe . 8839) - (oplus . 8853) - (otimes . 8855) - (perp . 8869) - (sdot . 8901) - (lceil . 8968) - (rceil . 8969) - (lfloor . 8970) - (rfloor . 8971) - (lang . 9001) - (rang . 9002) - (loz . 9674) - (spades . 9824) - (clubs . 9827) - (hearts . 9829) - (diams . 9830) - (quot . 34) - (amp . 38) - (lt . 60) - (gt . 62) - (OElig . 338) - (oelig . 339) - (Scaron . 352) - (scaron . 353) - (Yuml . 376) - (circ . 710) - (tilde . 732) - (ensp . 8194) - (emsp . 8195) - (thinsp . 8201) - (zwnj . 8204) - (zwj . 8205) - (lrm . 8206) - (rlm . 8207) - (ndash . 8211) - (mdash . 8212) - (lsquo . 8216) - (rsquo . 8217) - (sbquo . 8218) - (ldquo . 8220) - (rdquo . 8221) - (bdquo . 8222) - (dagger . 8224) - (Dagger . 8225) - (permil . 8240) - (lsaquo . 8249) - (rsaquo . 8250) - (euro . 8364))) +(define table + #hasheq((nbsp . 160) + (iexcl . 161) + (cent . 162) + (pound . 163) + (curren . 164) + (yen . 165) + (brvbar . 166) + (sect . 167) + (uml . 168) + (copy . 169) + (ordf . 170) + (laquo . 171) + (not . 172) + (shy . 173) + (reg . 174) + (macr . 175) + (deg . 176) + (plusmn . 177) + (sup2 . 178) + (sup3 . 179) + (acute . 180) + (micro . 181) + (para . 182) + (middot . 183) + (cedil . 184) + (sup1 . 185) + (ordm . 186) + (raquo . 187) + (frac14 . 188) + (frac12 . 189) + (frac34 . 190) + (iquest . 191) + (Agrave . 192) + (Aacute . 193) + (Acirc . 194) + (Atilde . 195) + (Auml . 196) + (Aring . 197) + (AElig . 198) + (Ccedil . 199) + (Egrave . 200) + (Eacute . 201) + (Ecirc . 202) + (Euml . 203) + (Igrave . 204) + (Iacute . 205) + (Icirc . 206) + (Iuml . 207) + (ETH . 208) + (Ntilde . 209) + (Ograve . 210) + (Oacute . 211) + (Ocirc . 212) + (Otilde . 213) + (Ouml . 214) + (times . 215) + (Oslash . 216) + (Ugrave . 217) + (Uacute . 218) + (Ucirc . 219) + (Uuml . 220) + (Yacute . 221) + (THORN . 222) + (szlig . 223) + (agrave . 224) + (aacute . 225) + (acirc . 226) + (atilde . 227) + (auml . 228) + (aring . 229) + (aelig . 230) + (ccedil . 231) + (egrave . 232) + (eacute . 233) + (ecirc . 234) + (euml . 235) + (igrave . 236) + (iacute . 237) + (icirc . 238) + (iuml . 239) + (eth . 240) + (ntilde . 241) + (ograve . 242) + (oacute . 243) + (ocirc . 244) + (otilde . 245) + (ouml . 246) + (divide . 247) + (oslash . 248) + (ugrave . 249) + (uacute . 250) + (ucirc . 251) + (uuml . 252) + (yacute . 253) + (thorn . 254) + (yuml . 255) + (fnof . 402) + (Alpha . 913) + (Beta . 914) + (Gamma . 915) + (Delta . 916) + (Epsilon . 917) + (Zeta . 918) + (Eta . 919) + (Theta . 920) + (Iota . 921) + (Kappa . 922) + (Lambda . 923) + (Mu . 924) + (Nu . 925) + (Xi . 926) + (Omicron . 927) + (Pi . 928) + (Rho . 929) + (Sigma . 931) + (Tau . 932) + (Upsilon . 933) + (Phi . 934) + (Chi . 935) + (Psi . 936) + (Omega . 937) + (alpha . 945) + (beta . 946) + (gamma . 947) + (delta . 948) + (epsilon . 949) + (zeta . 950) + (eta . 951) + (theta . 952) + (iota . 953) + (kappa . 954) + (lambda . 955) + (mu . 956) + (nu . 957) + (xi . 958) + (omicron . 959) + (pi . 960) + (rho . 961) + (sigmaf . 962) + (sigma . 963) + (tau . 964) + (upsilon . 965) + (phi . 966) + (chi . 967) + (psi . 968) + (omega . 969) + (thetasym . 977) + (upsih . 978) + (piv . 982) + (bull . 8226) + (hellip . 8230) + (prime . 8242) + (Prime . 8243) + (oline . 8254) + (frasl . 8260) + (weierp . 8472) + (image . 8465) + (real . 8476) + (trade . 8482) + (alefsym . 8501) + (larr . 8592) + (uarr . 8593) + (rarr . 8594) + (darr . 8595) + (harr . 8596) + (crarr . 8629) + (lArr . 8656) + (uArr . 8657) + (rArr . 8658) + (dArr . 8659) + (hArr . 8660) + (forall . 8704) + (part . 8706) + (exist . 8707) + (empty . 8709) + (nabla . 8711) + (isin . 8712) + (notin . 8713) + (ni . 8715) + (prod . 8719) + (sum . 8721) + (minus . 8722) + (lowast . 8727) + (radic . 8730) + (prop . 8733) + (infin . 8734) + (ang . 8736) + (and . 8743) + (or . 8744) + (cap . 8745) + (cup . 8746) + (int . 8747) + (there4 . 8756) + (sim . 8764) + (cong . 8773) + (asymp . 8776) + (ne . 8800) + (equiv . 8801) + (le . 8804) + (ge . 8805) + (sub . 8834) + (sup . 8835) + (nsub . 8836) + (sube . 8838) + (supe . 8839) + (oplus . 8853) + (otimes . 8855) + (perp . 8869) + (sdot . 8901) + (lceil . 8968) + (rceil . 8969) + (lfloor . 8970) + (rfloor . 8971) + (lang . 9001) + (rang . 9002) + (loz . 9674) + (spades . 9824) + (clubs . 9827) + (hearts . 9829) + (diams . 9830) + (quot . 34) + (amp . 38) + (lt . 60) + (gt . 62) + (OElig . 338) + (oelig . 339) + (Scaron . 352) + (scaron . 353) + (Yuml . 376) + (circ . 710) + (tilde . 732) + (ensp . 8194) + (emsp . 8195) + (thinsp . 8201) + (zwnj . 8204) + (zwj . 8205) + (lrm . 8206) + (rlm . 8207) + (ndash . 8211) + (mdash . 8212) + (lsquo . 8216) + (rsquo . 8217) + (sbquo . 8218) + (ldquo . 8220) + (rdquo . 8221) + (bdquo . 8222) + (dagger . 8224) + (Dagger . 8225) + (permil . 8240) + (lsaquo . 8249) + (rsaquo . 8250) + (euro . 8364))) - (define (entity-name->integer s) - (hash-table-get table s (lambda () #f)))) +(define (entity-name->integer s) + (hash-ref table s (lambda () #f))) diff --git a/pkgs/drracket/browser/private/html.rkt b/pkgs/drracket/browser/private/html.rkt index a68a9efc4f..0f97992d78 100644 --- a/pkgs/drracket/browser/private/html.rkt +++ b/pkgs/drracket/browser/private/html.rkt @@ -1,13 +1,13 @@ -#lang scheme/unit +#lang racket/unit (require "sig.rkt" mred/mred-sig - scheme/file - mzlib/port + racket/file + racket/port net/url-sig (only-in html read-html-as-xml read-html-comments use-html-spec) (except-in xml read-comments) - mzlib/class + racket/class "bullet.rkt" "option-snip.rkt" "entity-names.rkt") @@ -138,26 +138,26 @@ (inherit set-flags get-flags) (set-flags (cons 'handles-events (get-flags))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -;; Hardwired Scheme colorization; should come from a .css file +;; Hardwired Racket colorization; should come from a .css file ;; -(define (make-scheme-color-delta col) +(define (make-racket-color-delta col) (let ([d (make-object style-delta%)]) (send d set-delta-foreground col) d)) -(define scheme-code-delta (make-scheme-color-delta "brown")) -(define scheme-code-delta/keyword - (let ([d (make-scheme-color-delta (make-object color% #x99 0 0))]) +(define racket-code-delta (make-racket-color-delta "brown")) +(define racket-code-delta/keyword + (let ([d (make-racket-color-delta (make-object color% #x99 0 0))]) (send d set-weight-on 'bold) d)) -(define scheme-code-delta/variable (make-scheme-color-delta "navy")) -(define scheme-code-delta/global (make-scheme-color-delta "purple")) -(define scheme-code-delta/selfeval (make-scheme-color-delta "forest green")) -(define scheme-code-delta/comment (make-scheme-color-delta "cornflower blue")) -(define navigation-delta (let ([d (make-scheme-color-delta "red")]) +(define racket-code-delta/variable (make-racket-color-delta "navy")) +(define racket-code-delta/global (make-racket-color-delta "purple")) +(define racket-code-delta/selfeval (make-racket-color-delta "forest green")) +(define racket-code-delta/comment (make-racket-color-delta "cornflower blue")) +(define navigation-delta (let ([d (make-racket-color-delta "red")]) (send d set-style-on 'italic) d)) @@ -166,13 +166,13 @@ (define (lookup-class-delta class) (let ([class-path (cons class (current-style-class))]) (cond - [(sub-path? class-path '("scheme")) scheme-code-delta] - [(sub-path? class-path '("keyword" "scheme")) scheme-code-delta/keyword] - [(sub-path? class-path '("variable" "scheme")) scheme-code-delta/variable] - [(sub-path? class-path '("global" "scheme")) scheme-code-delta/global] - [(or (sub-path? class-path '("selfeval" "scheme")) - (sub-path? class-path '("schemeresponse"))) scheme-code-delta/selfeval] - [(sub-path? class-path '("comment" "scheme")) scheme-code-delta/comment] + [(sub-path? class-path '("racket")) racket-code-delta] + [(sub-path? class-path '("keyword" "racket")) racket-code-delta/keyword] + [(sub-path? class-path '("variable" "racket")) racket-code-delta/variable] + [(sub-path? class-path '("global" "racket")) racket-code-delta/global] + [(or (sub-path? class-path '("selfeval" "racket")) + (sub-path? class-path '("racketresponse"))) racket-code-delta/selfeval] + [(sub-path? class-path '("comment" "racket")) racket-code-delta/comment] [(sub-path? class-path '("navigation")) navigation-delta] [else #f]))) @@ -209,7 +209,7 @@ (define (get-bitmap-from-url url) (if (html-img-ok) - (let ([tmp-filename (make-temporary-file "mredimg~a")]) + (let ([tmp-filename (make-temporary-file "rktguiimg~a")]) (load-status #t "image" url) (call-with-output-file* tmp-filename (lambda (op) @@ -331,7 +331,7 @@ ;; parse-coords : string -> (listof number) ;; separates out a bunch of comma separated numbers in a string -;; into a list of scheme numbers +;; into a list of racket numbers (define (parse-coords str) (let loop ([str str]) (cond @@ -369,13 +369,13 @@ (let ([a (assq name (cadr e))]) (and a (cadr a)))) -(define get-mzscheme-arg - (let ([get-mz (make-get-field "mzscheme")]) +(define get-racket-arg + (let ([get-rkt (make-get-field "racket")]) (lambda (str) - (let ([v (get-mz str)]) - (and v (filter-mzscheme v)))))) + (let ([v (get-rkt str)]) + (and v (filter-racket v)))))) -(define filter-mzscheme +(define filter-racket (lambda (v) (regexp-replace* "[|]" v "\""))) @@ -475,12 +475,12 @@ [(symbol? c) (values c #t)] [(number? c) (values c #t)] [(comment? c) - (let ([code (get-mzscheme-arg (comment-text c))]) + (let ([code (get-racket-arg (comment-text c))]) (if code (let ([s (with-handlers ([exn:fail? (lambda (exn) (format - "Error during <!-- MZSCHEME=... -->: ~a" + "Error during <!-- RACKET=... -->: ~a" (if (exn? exn) (exn-message exn) (format "~s" exn))))]) @@ -646,9 +646,9 @@ (unescape str)))] [else #f])] [label (get-field s 'name)] - [scheme (let ([v (get-field s 'mzscheme)]) - (and v (filter-mzscheme v)))]) - (values url-string label scheme))))] + [racket (let ([v (get-field s 'racket)]) + (and v (filter-racket v)))]) + (values url-string label racket))))] [parse-font (let ([face-regexp (regexp "([^,]*), *(.*)")]) @@ -908,7 +908,7 @@ (delete pos (current-pos))) (values void forced-lines)] [(a) - (let-values ([(url-string label scheme) (parse-href e)]) + (let-values ([(url-string label racket) (parse-href e)]) (let* ([style (get-field e 'style)] [pos (current-pos)]) (let-values ([(r rfl) (rest)]) @@ -929,8 +929,8 @@ [label (send a-text add-tag label pos) (values r rfl)] - [scheme - (send a-text add-scheme-callback pos end-pos scheme) + [racket + (send a-text add-racket-callback pos end-pos racket) (values (lambda () (when (or (not style) diff --git a/pkgs/drracket/browser/private/hyper.rkt b/pkgs/drracket/browser/private/hyper.rkt index 8792977279..9738091ab4 100644 --- a/pkgs/drracket/browser/private/hyper.rkt +++ b/pkgs/drracket/browser/private/hyper.rkt @@ -1,8 +1,8 @@ #| A test case: -(module tmp mzscheme - (require mzlib/class mred browser framework) +#lang racket + (require racket/gui browser framework) (define f% (frame:status-line-mixin @@ -22,15 +22,16 @@ A test case: ;; The starting URL: "http://www.htdp.org/"; ;; #f means not a relative URL: - #f)) + #f) |# -#lang scheme/unit +#lang racket/unit -(require mzlib/class +(require racket/class + (only-in racket/list last-pair) "sig.rkt" - scheme/path - scheme/file + racket/path + racket/file net/url-sig net/url-structs net/head @@ -39,28 +40,22 @@ A test case: string-constants setup/plt-installer-sig) - -(import html^ + (import html^ mred^ setup:plt-installer^ url^) -(export hyper^) -(init-depend mred^) + (export hyper^) + (init-depend mred^) -(define (last-pair l) - (if (null? (cdr l)) - l - (last-pair (cdr l)))) - -(define-struct (exn:file-saved-instead exn) (pathname)) -(define-struct (exn:cancelled exn) ()) -(define-struct (exn:tcp-problem exn) ()) +(struct exn:file-saved-instead exn (pathname)) +(struct exn:cancelled exn ()) +(struct exn:tcp-problem exn ()) (define history-limit 20) -(define-struct hyperlink (anchor-start anchor-end url-string)) +(struct hyperlink (anchor-start anchor-end url-string)) -(define-struct hypertag (name position)) +(struct hypertag (name position)) (define (same-page-url? a b) (or (eq? a b) @@ -104,7 +99,7 @@ A test case: (equal? "file" (url-scheme url))) (with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) (path-below? - (normal-case-path (normalize-path (build-path (collection-path "mzlib") + (normal-case-path (normalize-path (build-path (collection-path "racket") 'up 'up))) (normal-case-path (normalize-path (apply build-path @@ -115,7 +110,7 @@ A test case: (define title #f) (define htmling? #f) (define redirection #f) - (define hypertags-list (list (make-hypertag "top" 0))) + (define hypertags-list (list (hypertag "top" 0))) (define hyper-delta (make-object style-delta% 'change-underline #t)) (let ([mult (send hyper-delta get-foreground-mult)] [add (send hyper-delta get-foreground-add)]) @@ -162,7 +157,7 @@ A test case: (when (string=? name (hypertag-name tag)) (remove-tag name))) hypertags-list) - (let ([new-tag (make-hypertag name pos)]) + (let ([new-tag (hypertag name pos)]) (set! hypertags-list (let insert-loop ([tags-left hypertags-list]) (cond [(null? tags-left)(cons new-tag '())] @@ -184,30 +179,30 @@ A test case: (filter (lambda (x) (not (string=? name (hypertag-name x)))) hypertags-list))) (define/public (add-link start end url-string) - (let* ([new-link (make-hyperlink start end url-string)]) + (let* ([new-link (hyperlink start end url-string)]) (set-clickback start end (lambda (x y z) (post-url url-string))))) ;; remember the directory when the callback is added (during parsing) ;; and restore it during the evaluation of the callback. - (define/public (add-scheme-callback start end scheme-string) + (define/public (add-racket-callback start end racket-string) (let ([dir (current-load-relative-directory)]) (set-clickback start end (lambda (edit start end) (if (url-allows-evaling? url) (parameterize ([current-load-relative-directory dir]) - (eval-scheme-string scheme-string)) + (eval-racket-string racket-string)) (message-box (string-constant help-desk) - " disabled")))))) + " disabled")))))) (define/public (add-thunk-callback start end thunk) (set-clickback start end (lambda (edit start end) (thunk)))) - (define/public (eval-scheme-string s) + (define/public (eval-racket-string s) (let ([v (dynamic-wind begin-busy-cursor @@ -388,13 +383,13 @@ A test case: (send d center) (send d show #t) (unless (or d? i?) - (raise (make-exn:cancelled + (raise (exn:cancelled "Package Cancelled" (current-continuation-marks)))) i?))] [tmp-plt-filename (if install? - (make-temporary-file "tmp~a.plt") + (make-temporary-file "tmp~a.rkt") (put-file (if size (format @@ -449,7 +444,7 @@ A test case: (queue-callback (lambda () (semaphore-post wait-to-start))) (send d show #t) (when exn - (raise (make-exn:tcp-problem (exn-message exn) (current-continuation-marks))))) + (raise (exn:tcp-problem (exn-message exn) (current-continuation-marks))))) (let ([sema (make-semaphore 0)]) (when (and tmp-plt-filename install?) (run-installer tmp-plt-filename @@ -458,13 +453,13 @@ A test case: (yield sema)))) (raise (if tmp-plt-filename - (make-exn:file-saved-instead + (exn:file-saved-instead (if install? (string-constant package-was-installed) (string-constant download-was-saved)) (current-continuation-marks) tmp-plt-filename) - (make-exn:cancelled "The download was cancelled." + (exn:cancelled "The download was cancelled." (current-continuation-marks)))))] [(or (and (url? url) (not (null? (url-path url))) @@ -576,9 +571,9 @@ A test case: ;; build-html-error-message : exn -> string[html] (define ((build-html-error-message str) exn) (string-append - "Error Evaluating Scheme" + "Error Evaluating Racket" "" - "

Error Evaluating Scheme Code

" + "

Error Evaluating Racket Code

" (format "
\n~a\n
" str) "

" (format "~a" @@ -743,7 +738,7 @@ A test case: (set-page (list e (or tag-pos 0) (send e last-position)) #t) (when tag-pos (send e set-position tag-pos)))] [(exn? result) - (message-box (string-constant drscheme) + (message-box (string-constant drracket) (exn-message result) tlw)] [else (void)])))))) diff --git a/pkgs/drracket/browser/private/option-snip.rkt b/pkgs/drracket/browser/private/option-snip.rkt index 9ff2b88469..c857ae12e3 100644 --- a/pkgs/drracket/browser/private/option-snip.rkt +++ b/pkgs/drracket/browser/private/option-snip.rkt @@ -1,201 +1,199 @@ -(module option-snip mzscheme - (require mred - mzlib/class - mzlib/string) +#lang racket +(require racket/gui) - (provide option-snip% - checkbox-snip%) +(provide option-snip% + checkbox-snip%) - (define inset 2) - (define arrow-sep 5) - (define arrow-height 5) +(define inset 2) +(define arrow-sep 5) +(define arrow-height 5) - (define arrow (list (make-object point% 0 0) - (make-object point% arrow-height arrow-height) - (make-object point% (* 2 arrow-height) 0))) +(define arrow (list (make-object point% 0 0) + (make-object point% arrow-height arrow-height) + (make-object point% (* 2 arrow-height) 0))) - (define arrow-cursor (make-object cursor% 'arrow)) +(define arrow-cursor (make-object cursor% 'arrow)) - (define option-snip% - (class snip% - (inherit get-admin set-snipclass set-count get-style get-flags set-flags) - (init-field [options null]) - (define w #f) - (define h #f) - (define d #f) - (define current-option #f) - (define look-for-option #f) ; a box when we're looking (in case we're looking for #f) +(define option-snip% + (class snip% + (inherit get-admin set-snipclass set-count get-style get-flags set-flags) + (init-field [options null]) + (define w #f) + (define h #f) + (define d #f) + (define current-option #f) + (define look-for-option #f) ; a box when we're looking (in case we're looking for #f) + + (define/public (add-option o v) + (set! options (append options (list (cons o v)))) + (when (and look-for-option + (equal? v (unbox look-for-option))) + (set! current-option (cons o v))) + (set! w #f) + (set! h #f) + (let ([a (get-admin)]) + (when a + (send a resized this #t)))) + + (define/public (get-value) + (with-handlers ([exn:fail? (lambda (x) #f)]) + (cdr (or current-option + (car options))))) + + (define/public (set-value v) + (let ([o (ormap (lambda (o) (and (equal? v (cdr o)) o)) options)]) + (if o + (set! current-option o) + (set! look-for-option (box v))))) + + (override* + [get-extent ; called by an editor to get the snip's size + (lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox) + (unless w + (let ([font (send (get-style) get-font)]) + (let ([w+h+ds + (map (lambda (o) + (let-values ([(tw th td ta) (send dc get-text-extent (car o) font)]) + (list tw th td))) + options)]) + (if (null? w+h+ds) + (begin + (set! w 10) + (set! h 10) + (set! d 2)) + (begin + (set! w (+ (* 2 inset) arrow-sep 2 (* 2 arrow-height) (apply max (map car w+h+ds)))) + (set! h (+ (* 2 inset) 1 (apply max arrow-height (map cadr w+h+ds)))) + (set! d (+ inset 1 (apply max (map caddr w+h+ds))))))))) + (when hbox + (set-box! hbox h)) + (when wbox + (set-box! wbox w)) + (when descentbox + (set-box! descentbox d)) + (when spacebox + (set-box! spacebox 0)) + (when rspacebox + (set-box! rspacebox 0)) + (when lspacebox + (set-box! lspacebox 0)))] + [draw ; called by an editor to draw the snip + (lambda (dc x y . other) + (unless w + (get-extent dc x y #f #f #f #f #f #f)) + (send dc draw-rectangle x y (sub1 w) (sub1 h)) + (send dc draw-line (+ x 1) (+ y h -1) (+ x w -1) (+ y h -1)) + (send dc draw-line (+ x w -1) (+ y 1) (+ x w -1) (+ y h -1)) + (let ([pen (send dc get-pen)] + [brush (send dc get-brush)]) + (send dc set-brush (send the-brush-list find-or-create-brush (send pen get-color) 'solid)) + (send dc draw-polygon arrow + (+ x (- w 2 inset (* 2 arrow-height))) + (+ y (/ (- h arrow-height) 2))) + (send dc set-brush brush)) + (unless (null? options) + (send dc draw-text (car (or current-option (car options))) (+ x inset) (+ y inset))))] + [copy + (lambda () + (make-object option-snip% options))] + [size-cache-invalid + (lambda () (set! w #f) (set! h #f))] + [on-event (lambda (dc x y editorx editory event) + (when (send event button-down?) + (let ([popup (make-object popup-menu%)]) + (for-each (lambda (o) + (make-object menu-item% (car o) popup + (lambda (i e) + (set! current-option o) + (let ([a (get-admin)]) + (when a + (send a needs-update this 0 0 w h)))))) + options) + (let ([a (get-admin)]) + (when a + (send a popup-menu popup this 0 0))))))] + [adjust-cursor (lambda (dc x y editorx editory event) + arrow-cursor)]) + (super-instantiate ()) + (set-flags (cons 'handles-events (get-flags))) + (set-count 1))) - (define/public (add-option o v) - (set! options (append options (list (cons o v)))) - (when (and look-for-option - (equal? v (unbox look-for-option))) - (set! current-option (cons o v))) - (set! w #f) - (set! h #f) - (let ([a (get-admin)]) - (when a - (send a resized this #t)))) - - (define/public (get-value) - (with-handlers ([exn:fail? (lambda (x) #f)]) - (cdr (or current-option - (car options))))) +(define cb-width 12) +(define cb-height 12) - (define/public (set-value v) - (let ([o (ormap (lambda (o) (and (equal? v (cdr o)) o)) options)]) - (if o - (set! current-option o) - (set! look-for-option (box v))))) - - (override* - [get-extent ; called by an editor to get the snip's size - (lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox) - (unless w - (let ([font (send (get-style) get-font)]) - (let ([w+h+ds - (map (lambda (o) - (let-values ([(tw th td ta) (send dc get-text-extent (car o) font)]) - (list tw th td))) - options)]) - (if (null? w+h+ds) - (begin - (set! w 10) - (set! h 10) - (set! d 2)) - (begin - (set! w (+ (* 2 inset) arrow-sep 2 (* 2 arrow-height) (apply max (map car w+h+ds)))) - (set! h (+ (* 2 inset) 1 (apply max arrow-height (map cadr w+h+ds)))) - (set! d (+ inset 1 (apply max (map caddr w+h+ds))))))))) - (when hbox - (set-box! hbox h)) - (when wbox - (set-box! wbox w)) - (when descentbox - (set-box! descentbox d)) - (when spacebox - (set-box! spacebox 0)) - (when rspacebox - (set-box! rspacebox 0)) - (when lspacebox - (set-box! lspacebox 0)))] - [draw ; called by an editor to draw the snip - (lambda (dc x y . other) - (unless w - (get-extent dc x y #f #f #f #f #f #f)) - (send dc draw-rectangle x y (sub1 w) (sub1 h)) - (send dc draw-line (+ x 1) (+ y h -1) (+ x w -1) (+ y h -1)) - (send dc draw-line (+ x w -1) (+ y 1) (+ x w -1) (+ y h -1)) - (let ([pen (send dc get-pen)] - [brush (send dc get-brush)]) - (send dc set-brush (send the-brush-list find-or-create-brush (send pen get-color) 'solid)) - (send dc draw-polygon arrow - (+ x (- w 2 inset (* 2 arrow-height))) - (+ y (/ (- h arrow-height) 2))) - (send dc set-brush brush)) - (unless (null? options) - (send dc draw-text (car (or current-option (car options))) (+ x inset) (+ y inset))))] - [copy - (lambda () - (make-object option-snip% options))] - [size-cache-invalid - (lambda () (set! w #f) (set! h #f))] - [on-event (lambda (dc x y editorx editory event) - (when (send event button-down?) - (let ([popup (make-object popup-menu%)]) - (for-each (lambda (o) - (make-object menu-item% (car o) popup - (lambda (i e) - (set! current-option o) - (let ([a (get-admin)]) - (when a - (send a needs-update this 0 0 w h)))))) - options) - (let ([a (get-admin)]) - (when a - (send a popup-menu popup this 0 0))))))] - [adjust-cursor (lambda (dc x y editorx editory event) - arrow-cursor)]) - (super-instantiate ()) - (set-flags (cons 'handles-events (get-flags))) - (set-count 1))) - - (define cb-width 12) - (define cb-height 12) - - (define checkbox-snip% - (class snip% - (inherit get-admin set-snipclass set-count get-style get-flags set-flags) - (init-field [checked? #f]) - (define tracking? #f) - (define hit? #f) - (define w cb-width) - (define h cb-height) - - (define/public (get-value) checked?) - - (override* - [get-extent ; called by an editor to get the snip's size - (lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox) - (when hbox - (set-box! hbox h)) - (when wbox - (set-box! wbox w)) - (when descentbox - (set-box! descentbox 0)) - (when spacebox - (set-box! spacebox 0)) - (when rspacebox - (set-box! rspacebox 0)) - (when lspacebox - (set-box! lspacebox 0)))] - [draw ; called by an editor to draw the snip - (lambda (dc x y . other) - (send dc draw-rectangle x y w h) - (when tracking? - (send dc draw-rectangle (+ x 1) (+ y 1) (- w 2) (- h 2))) - (when (or (and (not hit?) checked?) - (and hit? (not checked?))) - (send dc draw-line x y (+ x w -1) (+ y h -1)) - (send dc draw-line x (+ y h -1) (+ x w -1) y)))] - [copy - (lambda () - (make-object checkbox-snip% checked?))] - [on-event (lambda (dc x y editorx editory event) - (when (send event button-down?) - (set! tracking? #t) - (refresh) - (set! hit? #f)) - (if (or (send event button-down?) - (and tracking? (send event dragging?)) +(define checkbox-snip% + (class snip% + (inherit get-admin set-snipclass set-count get-style get-flags set-flags) + (init-field [checked? #f]) + (define tracking? #f) + (define hit? #f) + (define w cb-width) + (define h cb-height) + + (define/public (get-value) checked?) + + (override* + [get-extent ; called by an editor to get the snip's size + (lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox) + (when hbox + (set-box! hbox h)) + (when wbox + (set-box! wbox w)) + (when descentbox + (set-box! descentbox 0)) + (when spacebox + (set-box! spacebox 0)) + (when rspacebox + (set-box! rspacebox 0)) + (when lspacebox + (set-box! lspacebox 0)))] + [draw ; called by an editor to draw the snip + (lambda (dc x y . other) + (send dc draw-rectangle x y w h) + (when tracking? + (send dc draw-rectangle (+ x 1) (+ y 1) (- w 2) (- h 2))) + (when (or (and (not hit?) checked?) + (and hit? (not checked?))) + (send dc draw-line x y (+ x w -1) (+ y h -1)) + (send dc draw-line x (+ y h -1) (+ x w -1) y)))] + [copy + (lambda () + (make-object checkbox-snip% checked?))] + [on-event (lambda (dc x y editorx editory event) + (when (send event button-down?) + (set! tracking? #t) + (refresh) + (set! hit? #f)) + (if (or (send event button-down?) + (and tracking? (send event dragging?)) + (and tracking? (send event button-up?))) + (if (and (<= 0 (- (send event get-x) x)) + (<= 0 (- (send event get-y) y))) + (when (not hit?) + (set! hit? #t) + (refresh)) + (when hit? + (set! hit? #f) + (refresh))) + (when tracking? + (set! tracking? #f) + (set! hit? #f) + (refresh))) + (when (and tracking? (and tracking? (send event button-up?))) - (if (and (<= 0 (- (send event get-x) x)) - (<= 0 (- (send event get-y) y))) - (when (not hit?) - (set! hit? #t) - (refresh)) - (when hit? - (set! hit? #f) - (refresh))) - (when tracking? - (set! tracking? #f) - (set! hit? #f) - (refresh))) - (when (and tracking? - (and tracking? (send event button-up?))) - (set! tracking? #f) - (when hit? - (set! hit? #f) - (set! checked? (not checked?))) - (refresh)))] - [adjust-cursor (lambda (dc x y editorx editory event) - arrow-cursor)]) - - (define/private (refresh) - (let ([a (get-admin)]) - (when a - (send a needs-update this 0 0 w h)))) - - (super-instantiate ()) - (set-flags (cons 'handles-events (get-flags))) - (set-count 1)))) + (set! tracking? #f) + (when hit? + (set! hit? #f) + (set! checked? (not checked?))) + (refresh)))] + [adjust-cursor (lambda (dc x y editorx editory event) + arrow-cursor)]) + + (define/private (refresh) + (let ([a (get-admin)]) + (when a + (send a needs-update this 0 0 w h)))) + + (super-instantiate ()) + (set-flags (cons 'handles-events (get-flags))) + (set-count 1))) diff --git a/pkgs/drracket/browser/private/sig.rkt b/pkgs/drracket/browser/private/sig.rkt index fb7f5e98a3..f0a1fa52de 100644 --- a/pkgs/drracket/browser/private/sig.rkt +++ b/pkgs/drracket/browser/private/sig.rkt @@ -1,57 +1,57 @@ -(module sig scheme/base - (require scheme/unit) - - (provide relative-btree^ - bullet-export^ - hyper^ - html-export^ - html^) +#lang racket +(require racket/unit) - (define-signature html-export^ - (html-img-ok - html-eval-ok - image-map-snip%)) - - (define-signature html^ extends html-export^ - (html-convert - html-status-handler)) - - (define-signature bullet-export^ - (bullet-size)) - - (define-signature hyper^ - (open-url - (struct exn:file-saved-instead (pathname)) - (struct exn:cancelled ()) - - hyper-text<%> - hyper-text-mixin - hyper-text% - - hyper-canvas-mixin - hyper-canvas% - - hyper-panel<%> - hyper-panel-mixin - hyper-panel% - - hyper-frame<%> - hyper-frame-mixin - hyper-frame% - - hyper-no-show-frame-mixin - hyper-no-show-frame% - - editor->page - page->editor)) - - (define-signature relative-btree^ - (make-btree - - btree-get - btree-put! - - btree-shift! - - btree-for-each - btree-map))) +(provide relative-btree^ + bullet-export^ + hyper^ + html-export^ + html^) + +(define-signature html-export^ + (html-img-ok + html-eval-ok + image-map-snip%)) + +(define-signature html^ extends html-export^ + (html-convert + html-status-handler)) + +(define-signature bullet-export^ + (bullet-size)) + +(define-signature hyper^ + (open-url + (struct exn:file-saved-instead (pathname) #:omit-constructor) + (struct exn:cancelled () #:omit-constructor) + + hyper-text<%> + hyper-text-mixin + hyper-text% + + hyper-canvas-mixin + hyper-canvas% + + hyper-panel<%> + hyper-panel-mixin + hyper-panel% + + hyper-frame<%> + hyper-frame-mixin + hyper-frame% + + hyper-no-show-frame-mixin + hyper-no-show-frame% + + editor->page + page->editor)) + +(define-signature relative-btree^ + (make-btree + + btree-get + btree-put! + + btree-shift! + + btree-for-each + btree-map)) diff --git a/pkgs/drracket/browser/tool.rkt b/pkgs/drracket/browser/tool.rkt index a567317609..40d350d79b 100644 --- a/pkgs/drracket/browser/tool.rkt +++ b/pkgs/drracket/browser/tool.rkt @@ -1,15 +1,16 @@ -(module tool mzscheme - (require browser/external - mzlib/unit - drscheme/tool) - (provide tool@) +#lang racket +(require (only-in "external.rkt" install-help-browser-preference-panel) + racket/unit + drracket/tool) +(provide tool@) - ;; to add a preference pannel to drscheme that sets the browser preference - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - (define phase1 void) - (define phase2 void) - - (install-help-browser-preference-panel)))) +;; to add a preference pannel to drracket that sets the browser preference +(define tool@ + (unit + (import drracket:tool^) + (export drracket:tool-exports^) + + (define (phase1) (void)) + (define (phase2) (void)) + + (install-help-browser-preference-panel))) \ No newline at end of file diff --git a/pkgs/string-constants-lib/string-constants/private/danish-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/danish-string-constants.rkt index 0b299f4913..6f4384669a 100644 --- a/pkgs/string-constants-lib/string-constants/private/danish-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/danish-string-constants.rkt @@ -106,6 +106,7 @@ please adhere to these guidelines: ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "Ok") (cancel "Fortryd") (abort "Afbryd") diff --git a/pkgs/string-constants-lib/string-constants/private/dutch-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/dutch-string-constants.rkt index 60b41489bc..5afae09934 100644 --- a/pkgs/string-constants-lib/string-constants/private/dutch-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/dutch-string-constants.rkt @@ -19,6 +19,7 @@ ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "OK") (cancel "Annuleren") (untitled "Naamloos") diff --git a/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt index 4d395a7290..632ec1b8e5 100644 --- a/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt @@ -106,6 +106,7 @@ please adhere to these guidelines: ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "OK") (cancel "Cancel") (abort "Abort") diff --git a/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt index d5400e9b8b..fe9214d91b 100644 --- a/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt @@ -106,6 +106,7 @@ ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "OK") (cancel "Annuler") (abort "Abandonner") diff --git a/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt index 10021a4bcc..20878bd962 100644 --- a/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt @@ -13,6 +13,7 @@ ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "OK") ;; We can't use "Abbrechen" here because that's much closer in ;; meaning to "abort", and it appears in dialogs saying "Quit?" "OK" diff --git a/pkgs/string-constants-lib/string-constants/private/japanese-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/japanese-string-constants.rkt index b7b4938a70..c4da744a79 100644 --- a/pkgs/string-constants-lib/string-constants/private/japanese-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/japanese-string-constants.rkt @@ -106,6 +106,7 @@ please adhere to these guidelines: ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "OK") (cancel "キャンセル") (abort "中止") diff --git a/pkgs/string-constants-lib/string-constants/private/korean-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/korean-string-constants.rkt index ece2d1ae65..317756cdc1 100644 --- a/pkgs/string-constants-lib/string-constants/private/korean-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/korean-string-constants.rkt @@ -24,6 +24,7 @@ ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "확인") (cancel "취소") (abort "중단") diff --git a/pkgs/string-constants-lib/string-constants/private/portuguese-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/portuguese-string-constants.rkt index 86b5a36320..39e7e3fab8 100644 --- a/pkgs/string-constants-lib/string-constants/private/portuguese-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/portuguese-string-constants.rkt @@ -106,6 +106,7 @@ please adhere to these guidelines: ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "OK") (cancel "Cancelar") (abort "Abortar") diff --git a/pkgs/string-constants-lib/string-constants/private/russian-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/russian-string-constants.rkt index 9d87f750ed..cf8e7f1c55 100644 --- a/pkgs/string-constants-lib/string-constants/private/russian-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/russian-string-constants.rkt @@ -106,6 +106,7 @@ please adhere to these guidelines: ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "OK") (cancel "Отмена") (abort "Отмена") diff --git a/pkgs/string-constants-lib/string-constants/private/simplified-chinese-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/simplified-chinese-string-constants.rkt index 342e175bc4..847c5291b8 100644 --- a/pkgs/string-constants-lib/string-constants/private/simplified-chinese-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/simplified-chinese-string-constants.rkt @@ -33,6 +33,7 @@ ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "确定") (cancel "取消") (abort "中止") diff --git a/pkgs/string-constants-lib/string-constants/private/spanish-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/spanish-string-constants.rkt index f84b1d95c6..70fa55c866 100644 --- a/pkgs/string-constants-lib/string-constants/private/spanish-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/spanish-string-constants.rkt @@ -16,6 +16,7 @@ ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "OK") (cancel "Cancelar") (abort "Abortar") diff --git a/pkgs/string-constants-lib/string-constants/private/traditional-chinese-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/traditional-chinese-string-constants.rkt index 30699b0d68..8f93b2977f 100644 --- a/pkgs/string-constants-lib/string-constants/private/traditional-chinese-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/traditional-chinese-string-constants.rkt @@ -16,6 +16,8 @@ ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") + (ok "確定") (cancel "取消") (abort "中止") diff --git a/pkgs/string-constants-lib/string-constants/private/ukrainian-string-constants.rkt b/pkgs/string-constants-lib/string-constants/private/ukrainian-string-constants.rkt index 76e20a75f4..ac7e98cd97 100644 --- a/pkgs/string-constants-lib/string-constants/private/ukrainian-string-constants.rkt +++ b/pkgs/string-constants-lib/string-constants/private/ukrainian-string-constants.rkt @@ -106,6 +106,7 @@ please adhere to these guidelines: ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) (plt "PLT") (drscheme "DrRacket") + (drracket "DrRacket") (ok "OK") (cancel "Скасувати") (abort "Скасувати")