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

Browser-to-Racket

Browse Source 
Update the browser collection to use Racket lang instead of mzscheme.
This commit is contained in:
Patrick Mahoney 2013-02-23 00:47:18 -05:00 committed by Robby Findler
parent 9c4fcd4623
commit 2f2bbd09cc
30 changed files with 846 additions and 843 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/drracket/browser/browser-sig.rkt
View File

@ -1,10 +1,10 @@
(module browser-sig mzscheme #lang racket
(require mzlib/unit (require racket/unit
"private/sig.rkt") "private/sig.rkt")
(provide browser^) (provide browser^)
(define-signature browser^ (define-signature browser^
((open hyper^) ((open hyper^)
(open html-export^) (open html-export^)
(open bullet-export^)))) (open bullet-export^)))

63
pkgs/drracket/browser/browser-unit.rkt
View File

@ -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@) #lang racket/base
(require racket/unit
(define-unit-from-context bullet@ bullet-export^) mred/mred-sig
setup/plt-installer-sig
(define-compound-unit/infer pre-browser@ net/tcp-sig
(import setup:plt-installer^ net/url-sig
mred^ net/url-unit
url^) "browser-sig.rkt"
(export hyper^ html-export^ bullet-export^) "private/bullet.rkt"
(link html@ hyper@ bullet@)) "private/html.rkt"
"private/hyper.rkt"
(define-unit/new-import-export browser@ "private/sig.rkt")
(import setup:plt-installer^
mred^
url^)
(export browser^)
((hyper^ html-export^ bullet-export^)
pre-browser@
setup:plt-installer^
mred^
url^)))
(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^))

26
pkgs/drracket/browser/browser.rkt
View File

@ -1,15 +1,15 @@
(module browser mzscheme #lang racket
(require mzlib/unit (require racket/unit
mred racket/gui
mred/mred-sig mred/mred-sig
setup/plt-installer-sig setup/plt-installer-sig
setup/plt-installer setup/plt-installer
net/tcp-sig net/tcp-sig
net/url-sig net/url-sig
net/url net/url
"browser-sig.rkt" "browser-sig.rkt"
"browser-unit.rkt") "browser-unit.rkt")
(provide-signature-elements browser^) (provide-signature-elements browser^)
(define-values/invoke-unit/infer browser@)) (define-values/invoke-unit/infer browser@)

28
pkgs/drracket/browser/browser.scrbl
View File

@ -36,7 +36,7 @@ launching an external browser (such as Firefox).
@declare-exporting[browser/browser browser] @declare-exporting[browser/browser browser]
The browser supports basic HTML commands, plus special Racket hyperlinks The browser supports basic HTML commands, plus special Racket hyperlinks
of the form @litchar{<A MZSCHEME=sexpr>...</A>}. When the user clicks of the form @litchar{<A RACKET=sexpr>...</A>}. When the user clicks
on such a link, the string @racket[sexpr] is parsed as a Racket program on such a link, the string @racket[sexpr] is parsed as a Racket program
and evaluated. Since @racket[sexpr] is likely to contain Racket and evaluated. Since @racket[sexpr] is likely to contain Racket
strings, and since escape characters are difficult for people to read, a 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, character before it is parsed. Thus,
@verbatim[#:indent 2]{ @verbatim[#:indent 2]{
<A MZSCHEME="|This goes nowhere.|">Nowhere</A> <A RACKET="|This goes nowhere.|">Nowhere</A>
} }
creates a ``Nowhere'' hyperlink, which executes the Racket program 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.'' nowhere.''
The browser also treats comment forms containing The browser also treats comment forms containing
@litchar{MZSCHEME=sexpr} specially. Whereas the @litchar{RACKET=sexpr} specially. Whereas the
@litchar{<A MZSCHEME=sexpr>...</A>} form executes the expression when @litchar{<A RACKET=sexpr>...</A>} form executes the expression when
the user clicks, the @litchar{MZSCHEME} expression in a comment is the user clicks, the @litchar{RACKET} expression in a comment is
executed immediately during HTML rendering. If the result is a string, 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 the comment is replaced in the input HTML stream with the content of the
string. Thus, string. Thus,
@verbatim[#:indent 2]{ @verbatim[#:indent 2]{
<!-- MZSCHEME="(format |<B>Here</B>: ~a| (current-directory))" --> <!-- RACKET="(format |<B>Here</B>: ~a| (current-directory))" -->
} }
inserts the path of the current working directory into the containing 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 If the html file is being accessed as a @litchar{file:} url, the
@racket[current-load-relative-directory] parameter is set to 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]. 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. @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%)]{ @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?]{ @defboolparam[html-eval-ok ok?]{
A parameter that determines whether @litchar{MZSCHEME=} tags are A parameter that determines whether @litchar{RACKET=} tags are
evaluated. evaluated.
} }
@ -145,7 +145,7 @@ The @litchar{MZSCHEME} forms are disabled unless the web page is a
@definterface[hyper-text<%> ()]{ @definterface[hyper-text<%> ()]{
@defmethod[(url-allows-evalling? [url (or/c port? url?)]) boolean?]{ @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. 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]{ @defmethod[(eval-racket-string [str string?]) any]{
Called to handle the @litchar{<A MZSCHEME="expr">...</A>} tag and Called to handle the @litchar{<A RACKET="expr">...</A>} tag and
@litchar{<! MZSCHEME="expr">} comments (see above). Evaluates the @litchar{<! RACKET="expr">} comments (see above). Evaluates the
string; if the result is a string, it is opened as an HTML page. 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?] @defproc[(render-html-to-text [in input-port?]
[dest (is-a? html-text<%>)] [dest (is-a? html-text<%>)]
[load-img? any/c] [load-img? any/c]
[eval-mz? any/c]) [eval-rkt? any/c])
void?]{ void?]{
Reads HTML from @racket[in] and renders it to @racket[dest]. If 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 @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. hyperlink expressions and comments are not evaluated.
Uses the style named @racket["Html Standard"] in the editor's Uses the style named @racket["Html Standard"] in the editor's

6
pkgs/drracket/browser/bullet-snip.rkt
View File

@ -1,3 +1,3 @@
(module bullet-snip mzscheme #lang racket
(require "private/bullet.rkt") (require "private/bullet.rkt")
(provide (rename bullet-snip-class snip-class))) (provide (rename-out (bullet-snip-class snip-class)))

2
pkgs/drracket/browser/external.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require string-constants (require string-constants
mred racket/gui
racket/class racket/class
racket/file racket/file
racket/list racket/list

135
pkgs/drracket/browser/htmltext.rkt
View File

@ -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 (define-unit-from-context url@ url^)
(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-values/invoke-unit (define html-text<%>
(compound-unit/infer (import) (export html^) (interface ((class->interface text%))
(link standard-mred@ url@ html@)) get-url
(import) set-title
(export html^)) add-link
add-tag
make-link-style
add-racket-callback
add-thunk-callback
post-url))
(define html-text<%> (define url-delta (make-object style-delta% 'change-underline #t))
(interface ((class->interface text%)) (send url-delta set-delta-foreground "blue")
get-url
set-title
add-link
add-tag
make-link-style
add-scheme-callback
add-thunk-callback
post-url))
(define url-delta (make-object style-delta% 'change-underline #t)) (define html-text-mixin
(send url-delta set-delta-foreground "blue") (mixin ((class->interface text%)) (html-text<%>)
(inherit change-style set-clickback)
(define html-text-mixin (define/public (get-url) #f)
(mixin ((class->interface text%)) (html-text<%>) (define/public (set-title s) (void))
(inherit change-style set-clickback) (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/public (get-url) #f) (define (render-html-to-text port text%-obj img-ok? eval-ok?)
(define/public (set-title s) (void)) (unless (input-port? port)
(define/public (add-link pos end-pos url-string) (raise-type-error 'render-html-to-text "input port" 0 (list port text%-obj)))
(set-clickback pos end-pos (lambda (e start-pos eou-pos) (unless (text%-obj . is-a? . html-text<%>)
(send-url url-string)))) (raise-type-error 'render-html-to-text "html-text<%> object" 0 (list port text%-obj)))
(define/public (add-tag label pos) (void)) (parameterize ([html-eval-ok eval-ok?]
(define/public (make-link-style pos endpos) [html-img-ok img-ok?])
(change-style url-delta pos endpos)) (dynamic-wind
(define/public (add-scheme-callback pos endpos scheme) (void)) (lambda () (send text%-obj begin-edit-sequence #f))
(define/public (add-thunk-callback pos endpos thunk) (lambda () (html-convert port text%-obj))
(set-clickback pos endpos (lambda (e start-pos eou-pos) (lambda () (send text%-obj end-edit-sequence)))))
(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?) (provide html-text<%>
(unless (input-port? port) html-text-mixin
(raise-type-error 'render-html-to-text "input port" 0 (list port text%-obj))) render-html-to-text)
(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))

5
pkgs/drracket/browser/info.rkt
View File

@ -1,6 +1,5 @@
#lang setup/infotab #lang setup/infotab
(define tools (list (list "tool.rkt"))) (define drracket-tools (list (list "tool.rkt")))
(define tool-names (list "Browser")) (define drracket-tool-names (list "Browser"))
(define scribblings '(("browser.scrbl" () (gui-library)))) (define scribblings '(("browser.scrbl" () (gui-library))))

2
pkgs/drracket/browser/main.rkt
View File

@ -1,3 +1,3 @@
#lang scheme/base #lang racket/base
(require "browser.rkt") (require "browser.rkt")
(provide (all-from-out "browser.rkt")) (provide (all-from-out "browser.rkt"))

10
pkgs/drracket/browser/private/btree.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/unit #lang racket/unit
(require "sig.rkt") (require "sig.rkt")
@ -12,9 +12,9 @@
(export (rename relative-btree^ (export (rename relative-btree^
(create-btree make-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) (define (adjust-offsets n new-child)
(when new-child (when new-child
@ -66,7 +66,7 @@
(define (insert before? n btree pos data) (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)) (if (not (btree-root btree))
(set-btree-root! btree new) (set-btree-root! btree new)
@ -166,7 +166,7 @@
(loop (node-right n) so-far so-far-pos npos)])))))) (loop (node-right n) so-far so-far-pos npos)]))))))
(define (create-btree) (define (create-btree)
(make-btree #f)) (btree #f))
(define (btree-get btree pos) (define (btree-get btree pos)
(let-values ([(n npos) (find-following-node btree pos)]) (let-values ([(n npos) (find-following-node btree pos)])

168
pkgs/drracket/browser/private/bullet.rkt
View File

@ -1,94 +1,94 @@
(module bullet mzscheme #lang racket
(require mred (require racket/gui
mzlib/class) racket/class)
(provide bullet-snip% (provide bullet-snip%
get-bullet-width get-bullet-width
bullet-size bullet-size
bullet-snip-class) bullet-snip-class)
(define snip-class-name "(lib \"bullet-snip.ss\" \"browser\")") (define snip-class-name "(lib \"bullet-snip.rkt\" \"browser\")")
(define bullet-size (define bullet-size
(make-parameter (make-parameter
(let ([s (send (send (send (make-object text%) get-style-list) basic-style) (let ([s (send (send (send (make-object text%) get-style-list) basic-style)
get-size)]) get-size)])
(max 7 (quotient s 2))))) (max 7 (quotient s 2)))))
(define (get-bullet-width) (define (get-bullet-width)
(* 2 (bullet-size))) (* 2 (bullet-size)))
(define transparent-brush (send the-brush-list find-or-create-brush "WHITE" 'transparent)) (define transparent-brush (send the-brush-list find-or-create-brush "WHITE" 'transparent))
(define bullet-snip% (define bullet-snip%
(class snip% (class snip%
(init-field depth) (init-field depth)
(inherit set-snipclass set-count get-style) (inherit set-snipclass set-count get-style)
(define bsize (bullet-size)) (define bsize (bullet-size))
(define/private (zero b) (when b (set-box! b 0))) (define/private (zero b) (when b (set-box! b 0)))
[define/private get-height [define/private get-height
(lambda (dc) (lambda (dc)
(let ([s (get-style)]) (let ([s (get-style)])
(max bsize (- (send s get-text-height dc) (max bsize (- (send s get-text-height dc)
(send s get-text-descent dc)))))] (send s get-text-descent dc)))))]
[define/override get-extent [define/override get-extent
(lambda (dc x y wbox hbox descentbox spacebox (lambda (dc x y wbox hbox descentbox spacebox
lspacebox rspacebox) lspacebox rspacebox)
(when hbox (when hbox
(set-box! hbox (get-height dc))) (set-box! hbox (get-height dc)))
(when wbox (when wbox
(set-box! wbox (* 2 bsize))) (set-box! wbox (* 2 bsize)))
(zero descentbox) (zero descentbox)
(zero spacebox) (zero spacebox)
(zero rspacebox) (zero rspacebox)
(zero lspacebox))] (zero lspacebox))]
[define/override draw [define/override draw
(lambda (dc x y . other) (lambda (dc x y . other)
(let ([y (+ y (ceiling (/ (- (get-height dc) bsize) 2)))]) (let ([y (+ y (ceiling (/ (- (get-height dc) bsize) 2)))])
(let-values ([(draw solid?) (let-values ([(draw solid?)
(case depth (case depth
[(0) (values (lambda (x y w h) (send dc draw-ellipse x y w h)) #t)] [(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)] [(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)])]) [else (values (lambda (x y w h) (send dc draw-rectangle x y w h)) #f)])])
(let ([b (send dc get-brush)]) (let ([b (send dc get-brush)])
(send dc set-brush (send dc set-brush
(if solid? (if solid?
(send the-brush-list (send the-brush-list
find-or-create-brush find-or-create-brush
(send (send dc get-pen) get-color) (send (send dc get-pen) get-color)
'solid) 'solid)
transparent-brush)) transparent-brush))
(draw x y bsize bsize) (draw x y bsize bsize)
(send dc set-brush b)))))] (send dc set-brush b)))))]
[define/override copy [define/override copy
(lambda () (lambda ()
(make-object bullet-snip% depth))] (make-object bullet-snip% depth))]
[define/override write [define/override write
(lambda (stream) (lambda (stream)
(send stream put depth))] (send stream put depth))]
[define/override get-text [define/override get-text
(lambda (offset num flattened?) (lambda (offset num flattened?)
(if (< num 1) (if (< num 1)
"" ""
(if flattened? (if flattened?
"* " "* "
"*")))] "*")))]
(super-new) (super-new)
(set-snipclass bullet-snip-class) (set-snipclass bullet-snip-class)
(set-count 1))) (set-count 1)))
(define bullet-snip-class (define bullet-snip-class
(make-object (make-object
(class snip-class% (class snip-class%
(inherit set-classname) (inherit set-classname)
[define/override read [define/override read
(lambda (stream) (lambda (stream)
(let ([d-box (box 0)]) (let ([d-box (box 0)])
(send stream get d-box) (send stream get d-box)
(make-object bullet-snip% (unbox d-box))))] (make-object bullet-snip% (unbox d-box))))]
(super-new) (super-new)
(set-classname snip-class-name)))) (set-classname snip-class-name))))
(send (get-the-snip-class-list) add bullet-snip-class)) (send (get-the-snip-class-list) add bullet-snip-class)

514
pkgs/drracket/browser/private/entity-names.rkt
View File

@ -1,261 +1,261 @@
(module entity-names mzscheme #lang racket
(provide entity-name->integer) (provide entity-name->integer)
(define table (define table
#cs#hasheq((nbsp . 160) #hasheq((nbsp . 160)
(iexcl . 161) (iexcl . 161)
(cent . 162) (cent . 162)
(pound . 163) (pound . 163)
(curren . 164) (curren . 164)
(yen . 165) (yen . 165)
(brvbar . 166) (brvbar . 166)
(sect . 167) (sect . 167)
(uml . 168) (uml . 168)
(copy . 169) (copy . 169)
(ordf . 170) (ordf . 170)
(laquo . 171) (laquo . 171)
(not . 172) (not . 172)
(shy . 173) (shy . 173)
(reg . 174) (reg . 174)
(macr . 175) (macr . 175)
(deg . 176) (deg . 176)
(plusmn . 177) (plusmn . 177)
(sup2 . 178) (sup2 . 178)
(sup3 . 179) (sup3 . 179)
(acute . 180) (acute . 180)
(micro . 181) (micro . 181)
(para . 182) (para . 182)
(middot . 183) (middot . 183)
(cedil . 184) (cedil . 184)
(sup1 . 185) (sup1 . 185)
(ordm . 186) (ordm . 186)
(raquo . 187) (raquo . 187)
(frac14 . 188) (frac14 . 188)
(frac12 . 189) (frac12 . 189)
(frac34 . 190) (frac34 . 190)
(iquest . 191) (iquest . 191)
(Agrave . 192) (Agrave . 192)
(Aacute . 193) (Aacute . 193)
(Acirc . 194) (Acirc . 194)
(Atilde . 195) (Atilde . 195)
(Auml . 196) (Auml . 196)
(Aring . 197) (Aring . 197)
(AElig . 198) (AElig . 198)
(Ccedil . 199) (Ccedil . 199)
(Egrave . 200) (Egrave . 200)
(Eacute . 201) (Eacute . 201)
(Ecirc . 202) (Ecirc . 202)
(Euml . 203) (Euml . 203)
(Igrave . 204) (Igrave . 204)
(Iacute . 205) (Iacute . 205)
(Icirc . 206) (Icirc . 206)
(Iuml . 207) (Iuml . 207)
(ETH . 208) (ETH . 208)
(Ntilde . 209) (Ntilde . 209)
(Ograve . 210) (Ograve . 210)
(Oacute . 211) (Oacute . 211)
(Ocirc . 212) (Ocirc . 212)
(Otilde . 213) (Otilde . 213)
(Ouml . 214) (Ouml . 214)
(times . 215) (times . 215)
(Oslash . 216) (Oslash . 216)
(Ugrave . 217) (Ugrave . 217)
(Uacute . 218) (Uacute . 218)
(Ucirc . 219) (Ucirc . 219)
(Uuml . 220) (Uuml . 220)
(Yacute . 221) (Yacute . 221)
(THORN . 222) (THORN . 222)
(szlig . 223) (szlig . 223)
(agrave . 224) (agrave . 224)
(aacute . 225) (aacute . 225)
(acirc . 226) (acirc . 226)
(atilde . 227) (atilde . 227)
(auml . 228) (auml . 228)
(aring . 229) (aring . 229)
(aelig . 230) (aelig . 230)
(ccedil . 231) (ccedil . 231)
(egrave . 232) (egrave . 232)
(eacute . 233) (eacute . 233)
(ecirc . 234) (ecirc . 234)
(euml . 235) (euml . 235)
(igrave . 236) (igrave . 236)
(iacute . 237) (iacute . 237)
(icirc . 238) (icirc . 238)
(iuml . 239) (iuml . 239)
(eth . 240) (eth . 240)
(ntilde . 241) (ntilde . 241)
(ograve . 242) (ograve . 242)
(oacute . 243) (oacute . 243)
(ocirc . 244) (ocirc . 244)
(otilde . 245) (otilde . 245)
(ouml . 246) (ouml . 246)
(divide . 247) (divide . 247)
(oslash . 248) (oslash . 248)
(ugrave . 249) (ugrave . 249)
(uacute . 250) (uacute . 250)
(ucirc . 251) (ucirc . 251)
(uuml . 252) (uuml . 252)
(yacute . 253) (yacute . 253)
(thorn . 254) (thorn . 254)
(yuml . 255) (yuml . 255)
(fnof . 402) (fnof . 402)
(Alpha . 913) (Alpha . 913)
(Beta . 914) (Beta . 914)
(Gamma . 915) (Gamma . 915)
(Delta . 916) (Delta . 916)
(Epsilon . 917) (Epsilon . 917)
(Zeta . 918) (Zeta . 918)
(Eta . 919) (Eta . 919)
(Theta . 920) (Theta . 920)
(Iota . 921) (Iota . 921)
(Kappa . 922) (Kappa . 922)
(Lambda . 923) (Lambda . 923)
(Mu . 924) (Mu . 924)
(Nu . 925) (Nu . 925)
(Xi . 926) (Xi . 926)
(Omicron . 927) (Omicron . 927)
(Pi . 928) (Pi . 928)
(Rho . 929) (Rho . 929)
(Sigma . 931) (Sigma . 931)
(Tau . 932) (Tau . 932)
(Upsilon . 933) (Upsilon . 933)
(Phi . 934) (Phi . 934)
(Chi . 935) (Chi . 935)
(Psi . 936) (Psi . 936)
(Omega . 937) (Omega . 937)
(alpha . 945) (alpha . 945)
(beta . 946) (beta . 946)
(gamma . 947) (gamma . 947)
(delta . 948) (delta . 948)
(epsilon . 949) (epsilon . 949)
(zeta . 950) (zeta . 950)
(eta . 951) (eta . 951)
(theta . 952) (theta . 952)
(iota . 953) (iota . 953)
(kappa . 954) (kappa . 954)
(lambda . 955) (lambda . 955)
(mu . 956) (mu . 956)
(nu . 957) (nu . 957)
(xi . 958) (xi . 958)
(omicron . 959) (omicron . 959)
(pi . 960) (pi . 960)
(rho . 961) (rho . 961)
(sigmaf . 962) (sigmaf . 962)
(sigma . 963) (sigma . 963)
(tau . 964) (tau . 964)
(upsilon . 965) (upsilon . 965)
(phi . 966) (phi . 966)
(chi . 967) (chi . 967)
(psi . 968) (psi . 968)
(omega . 969) (omega . 969)
(thetasym . 977) (thetasym . 977)
(upsih . 978) (upsih . 978)
(piv . 982) (piv . 982)
(bull . 8226) (bull . 8226)
(hellip . 8230) (hellip . 8230)
(prime . 8242) (prime . 8242)
(Prime . 8243) (Prime . 8243)
(oline . 8254) (oline . 8254)
(frasl . 8260) (frasl . 8260)
(weierp . 8472) (weierp . 8472)
(image . 8465) (image . 8465)
(real . 8476) (real . 8476)
(trade . 8482) (trade . 8482)
(alefsym . 8501) (alefsym . 8501)
(larr . 8592) (larr . 8592)
(uarr . 8593) (uarr . 8593)
(rarr . 8594) (rarr . 8594)
(darr . 8595) (darr . 8595)
(harr . 8596) (harr . 8596)
(crarr . 8629) (crarr . 8629)
(lArr . 8656) (lArr . 8656)
(uArr . 8657) (uArr . 8657)
(rArr . 8658) (rArr . 8658)
(dArr . 8659) (dArr . 8659)
(hArr . 8660) (hArr . 8660)
(forall . 8704) (forall . 8704)
(part . 8706) (part . 8706)
(exist . 8707) (exist . 8707)
(empty . 8709) (empty . 8709)
(nabla . 8711) (nabla . 8711)
(isin . 8712) (isin . 8712)
(notin . 8713) (notin . 8713)
(ni . 8715) (ni . 8715)
(prod . 8719) (prod . 8719)
(sum . 8721) (sum . 8721)
(minus . 8722) (minus . 8722)
(lowast . 8727) (lowast . 8727)
(radic . 8730) (radic . 8730)
(prop . 8733) (prop . 8733)
(infin . 8734) (infin . 8734)
(ang . 8736) (ang . 8736)
(and . 8743) (and . 8743)
(or . 8744) (or . 8744)
(cap . 8745) (cap . 8745)
(cup . 8746) (cup . 8746)
(int . 8747) (int . 8747)
(there4 . 8756) (there4 . 8756)
(sim . 8764) (sim . 8764)
(cong . 8773) (cong . 8773)
(asymp . 8776) (asymp . 8776)
(ne . 8800) (ne . 8800)
(equiv . 8801) (equiv . 8801)
(le . 8804) (le . 8804)
(ge . 8805) (ge . 8805)
(sub . 8834) (sub . 8834)
(sup . 8835) (sup . 8835)
(nsub . 8836) (nsub . 8836)
(sube . 8838) (sube . 8838)
(supe . 8839) (supe . 8839)
(oplus . 8853) (oplus . 8853)
(otimes . 8855) (otimes . 8855)
(perp . 8869) (perp . 8869)
(sdot . 8901) (sdot . 8901)
(lceil . 8968) (lceil . 8968)
(rceil . 8969) (rceil . 8969)
(lfloor . 8970) (lfloor . 8970)
(rfloor . 8971) (rfloor . 8971)
(lang . 9001) (lang . 9001)
(rang . 9002) (rang . 9002)
(loz . 9674) (loz . 9674)
(spades . 9824) (spades . 9824)
(clubs . 9827) (clubs . 9827)
(hearts . 9829) (hearts . 9829)
(diams . 9830) (diams . 9830)
(quot . 34) (quot . 34)
(amp . 38) (amp . 38)
(lt . 60) (lt . 60)
(gt . 62) (gt . 62)
(OElig . 338) (OElig . 338)
(oelig . 339) (oelig . 339)
(Scaron . 352) (Scaron . 352)
(scaron . 353) (scaron . 353)
(Yuml . 376) (Yuml . 376)
(circ . 710) (circ . 710)
(tilde . 732) (tilde . 732)
(ensp . 8194) (ensp . 8194)
(emsp . 8195) (emsp . 8195)
(thinsp . 8201) (thinsp . 8201)
(zwnj . 8204) (zwnj . 8204)
(zwj . 8205) (zwj . 8205)
(lrm . 8206) (lrm . 8206)
(rlm . 8207) (rlm . 8207)
(ndash . 8211) (ndash . 8211)
(mdash . 8212) (mdash . 8212)
(lsquo . 8216) (lsquo . 8216)
(rsquo . 8217) (rsquo . 8217)
(sbquo . 8218) (sbquo . 8218)
(ldquo . 8220) (ldquo . 8220)
(rdquo . 8221) (rdquo . 8221)
(bdquo . 8222) (bdquo . 8222)
(dagger . 8224) (dagger . 8224)
(Dagger . 8225) (Dagger . 8225)
(permil . 8240) (permil . 8240)
(lsaquo . 8249) (lsaquo . 8249)
(rsaquo . 8250) (rsaquo . 8250)
(euro . 8364))) (euro . 8364)))
(define (entity-name->integer s) (define (entity-name->integer s)
(hash-table-get table s (lambda () #f)))) (hash-ref table s (lambda () #f)))

74
pkgs/drracket/browser/private/html.rkt
View File

@ -1,13 +1,13 @@
#lang scheme/unit #lang racket/unit
(require "sig.rkt" (require "sig.rkt"
mred/mred-sig mred/mred-sig
scheme/file racket/file
mzlib/port racket/port
net/url-sig net/url-sig
(only-in html read-html-as-xml read-html-comments use-html-spec) (only-in html read-html-as-xml read-html-comments use-html-spec)
(except-in xml read-comments) (except-in xml read-comments)
mzlib/class racket/class
"bullet.rkt" "bullet.rkt"
"option-snip.rkt" "option-snip.rkt"
"entity-names.rkt") "entity-names.rkt")
@ -138,26 +138,26 @@
(inherit set-flags get-flags) (inherit set-flags get-flags)
(set-flags (cons 'handles-events (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%)]) (let ([d (make-object style-delta%)])
(send d set-delta-foreground col) (send d set-delta-foreground col)
d)) d))
(define scheme-code-delta (make-scheme-color-delta "brown")) (define racket-code-delta (make-racket-color-delta "brown"))
(define scheme-code-delta/keyword (define racket-code-delta/keyword
(let ([d (make-scheme-color-delta (make-object color% #x99 0 0))]) (let ([d (make-racket-color-delta (make-object color% #x99 0 0))])
(send d set-weight-on 'bold) (send d set-weight-on 'bold)
d)) d))
(define scheme-code-delta/variable (make-scheme-color-delta "navy")) (define racket-code-delta/variable (make-racket-color-delta "navy"))
(define scheme-code-delta/global (make-scheme-color-delta "purple")) (define racket-code-delta/global (make-racket-color-delta "purple"))
(define scheme-code-delta/selfeval (make-scheme-color-delta "forest green")) (define racket-code-delta/selfeval (make-racket-color-delta "forest green"))
(define scheme-code-delta/comment (make-scheme-color-delta "cornflower blue")) (define racket-code-delta/comment (make-racket-color-delta "cornflower blue"))
(define navigation-delta (let ([d (make-scheme-color-delta "red")]) (define navigation-delta (let ([d (make-racket-color-delta "red")])
(send d set-style-on 'italic) (send d set-style-on 'italic)
d)) d))
@ -166,13 +166,13 @@
(define (lookup-class-delta class) (define (lookup-class-delta class)
(let ([class-path (cons class (current-style-class))]) (let ([class-path (cons class (current-style-class))])
(cond (cond
[(sub-path? class-path '("scheme")) scheme-code-delta] [(sub-path? class-path '("racket")) racket-code-delta]
[(sub-path? class-path '("keyword" "scheme")) scheme-code-delta/keyword] [(sub-path? class-path '("keyword" "racket")) racket-code-delta/keyword]
[(sub-path? class-path '("variable" "scheme")) scheme-code-delta/variable] [(sub-path? class-path '("variable" "racket")) racket-code-delta/variable]
[(sub-path? class-path '("global" "scheme")) scheme-code-delta/global] [(sub-path? class-path '("global" "racket")) racket-code-delta/global]
[(or (sub-path? class-path '("selfeval" "scheme")) [(or (sub-path? class-path '("selfeval" "racket"))
(sub-path? class-path '("schemeresponse"))) scheme-code-delta/selfeval] (sub-path? class-path '("racketresponse"))) racket-code-delta/selfeval]
[(sub-path? class-path '("comment" "scheme")) scheme-code-delta/comment] [(sub-path? class-path '("comment" "racket")) racket-code-delta/comment]
[(sub-path? class-path '("navigation")) navigation-delta] [(sub-path? class-path '("navigation")) navigation-delta]
[else #f]))) [else #f])))
@ -209,7 +209,7 @@
(define (get-bitmap-from-url url) (define (get-bitmap-from-url url)
(if (html-img-ok) (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) (load-status #t "image" url)
(call-with-output-file* tmp-filename (call-with-output-file* tmp-filename
(lambda (op) (lambda (op)
@ -331,7 +331,7 @@
;; parse-coords : string -> (listof number) ;; parse-coords : string -> (listof number)
;; separates out a bunch of comma separated numbers in a string ;; 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) (define (parse-coords str)
(let loop ([str str]) (let loop ([str str])
(cond (cond
@ -369,13 +369,13 @@
(let ([a (assq name (cadr e))]) (let ([a (assq name (cadr e))])
(and a (cadr a)))) (and a (cadr a))))
(define get-mzscheme-arg (define get-racket-arg
(let ([get-mz (make-get-field "mzscheme")]) (let ([get-rkt (make-get-field "racket")])
(lambda (str) (lambda (str)
(let ([v (get-mz str)]) (let ([v (get-rkt str)])
(and v (filter-mzscheme v)))))) (and v (filter-racket v))))))
(define filter-mzscheme (define filter-racket
(lambda (v) (lambda (v)
(regexp-replace* "[|]" v "\""))) (regexp-replace* "[|]" v "\"")))
@ -475,12 +475,12 @@
[(symbol? c) (values c #t)] [(symbol? c) (values c #t)]
[(number? c) (values c #t)] [(number? c) (values c #t)]
[(comment? c) [(comment? c)
(let ([code (get-mzscheme-arg (comment-text c))]) (let ([code (get-racket-arg (comment-text c))])
(if code (if code
(let ([s (with-handlers ([exn:fail? (let ([s (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)
(format (format
"<font color=\"red\">Error during &lt;!-- MZSCHEME=... --&gt;: <i>~a</i></font>" "<font color=\"red\">Error during &lt;!-- RACKET=... --&gt;: <i>~a</i></font>"
(if (exn? exn) (if (exn? exn)
(exn-message exn) (exn-message exn)
(format "~s" exn))))]) (format "~s" exn))))])
@ -646,9 +646,9 @@
(unescape str)))] (unescape str)))]
[else #f])] [else #f])]
[label (get-field s 'name)] [label (get-field s 'name)]
[scheme (let ([v (get-field s 'mzscheme)]) [racket (let ([v (get-field s 'racket)])
(and v (filter-mzscheme v)))]) (and v (filter-racket v)))])
(values url-string label scheme))))] (values url-string label racket))))]
[parse-font [parse-font
(let ([face-regexp (regexp "([^,]*), *(.*)")]) (let ([face-regexp (regexp "([^,]*), *(.*)")])
@ -908,7 +908,7 @@
(delete pos (current-pos))) (delete pos (current-pos)))
(values void forced-lines)] (values void forced-lines)]
[(a) [(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)] (let* ([style (get-field e 'style)]
[pos (current-pos)]) [pos (current-pos)])
(let-values ([(r rfl) (rest)]) (let-values ([(r rfl) (rest)])
@ -929,8 +929,8 @@
[label [label
(send a-text add-tag label pos) (send a-text add-tag label pos)
(values r rfl)] (values r rfl)]
[scheme [racket
(send a-text add-scheme-callback pos end-pos scheme) (send a-text add-racket-callback pos end-pos racket)
(values (values
(lambda () (lambda ()
(when (or (not style) (when (or (not style)

69
pkgs/drracket/browser/private/hyper.rkt
View File

@ -1,8 +1,8 @@
#| #|
A test case: A test case:
(module tmp mzscheme #lang racket
(require mzlib/class mred browser framework) (require racket/gui browser framework)
(define f% (define f%
(frame:status-line-mixin (frame:status-line-mixin
@ -22,15 +22,16 @@ A test case:
;; The starting URL: ;; The starting URL:
"http://www.htdp.org/"; "http://www.htdp.org/";
;; #f means not a relative URL: ;; #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" "sig.rkt"
scheme/path racket/path
scheme/file racket/file
net/url-sig net/url-sig
net/url-structs net/url-structs
net/head net/head
@ -39,28 +40,22 @@ A test case:
string-constants string-constants
setup/plt-installer-sig) setup/plt-installer-sig)
(import html^
(import html^
mred^ mred^
setup:plt-installer^ setup:plt-installer^
url^) url^)
(export hyper^) (export hyper^)
(init-depend mred^) (init-depend mred^)
(define (last-pair l) (struct exn:file-saved-instead exn (pathname))
(if (null? (cdr l)) (struct exn:cancelled exn ())
l (struct exn:tcp-problem exn ())
(last-pair (cdr l))))
(define-struct (exn:file-saved-instead exn) (pathname))
(define-struct (exn:cancelled exn) ())
(define-struct (exn:tcp-problem exn) ())
(define history-limit 20) (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) (define (same-page-url? a b)
(or (eq? a b) (or (eq? a b)
@ -104,7 +99,7 @@ A test case:
(equal? "file" (url-scheme url))) (equal? "file" (url-scheme url)))
(with-handlers ([exn:fail:filesystem? (lambda (x) #f)]) (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
(path-below? (path-below?
(normal-case-path (normalize-path (build-path (collection-path "mzlib") (normal-case-path (normalize-path (build-path (collection-path "racket")
'up 'up
'up))) 'up)))
(normal-case-path (normalize-path (apply build-path (normal-case-path (normalize-path (apply build-path
@ -115,7 +110,7 @@ A test case:
(define title #f) (define title #f)
(define htmling? #f) (define htmling? #f)
(define redirection #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)) (define hyper-delta (make-object style-delta% 'change-underline #t))
(let ([mult (send hyper-delta get-foreground-mult)] (let ([mult (send hyper-delta get-foreground-mult)]
[add (send hyper-delta get-foreground-add)]) [add (send hyper-delta get-foreground-add)])
@ -162,7 +157,7 @@ A test case:
(when (string=? name (hypertag-name tag)) (when (string=? name (hypertag-name tag))
(remove-tag name))) (remove-tag name)))
hypertags-list) hypertags-list)
(let ([new-tag (make-hypertag name pos)]) (let ([new-tag (hypertag name pos)])
(set! hypertags-list (set! hypertags-list
(let insert-loop ([tags-left hypertags-list]) (let insert-loop ([tags-left hypertags-list])
(cond [(null? tags-left)(cons new-tag '())] (cond [(null? tags-left)(cons new-tag '())]
@ -184,30 +179,30 @@ A test case:
(filter (lambda (x) (not (string=? name (hypertag-name x)))) (filter (lambda (x) (not (string=? name (hypertag-name x))))
hypertags-list))) hypertags-list)))
(define/public (add-link start end url-string) (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 (set-clickback start end
(lambda (x y z) (lambda (x y z)
(post-url url-string))))) (post-url url-string)))))
;; remember the directory when the callback is added (during parsing) ;; remember the directory when the callback is added (during parsing)
;; and restore it during the evaluation of the callback. ;; 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)]) (let ([dir (current-load-relative-directory)])
(set-clickback (set-clickback
start end start end
(lambda (edit start end) (lambda (edit start end)
(if (url-allows-evaling? url) (if (url-allows-evaling? url)
(parameterize ([current-load-relative-directory dir]) (parameterize ([current-load-relative-directory dir])
(eval-scheme-string scheme-string)) (eval-racket-string racket-string))
(message-box (string-constant help-desk) (message-box (string-constant help-desk)
"<A MZSCHEME= ...> disabled")))))) "<A RACKET= ...> disabled"))))))
(define/public (add-thunk-callback start end thunk) (define/public (add-thunk-callback start end thunk)
(set-clickback (set-clickback
start end start end
(lambda (edit start end) (lambda (edit start end)
(thunk)))) (thunk))))
(define/public (eval-scheme-string s) (define/public (eval-racket-string s)
(let ([v (let ([v
(dynamic-wind (dynamic-wind
begin-busy-cursor begin-busy-cursor
@ -388,13 +383,13 @@ A test case:
(send d center) (send d center)
(send d show #t) (send d show #t)
(unless (or d? i?) (unless (or d? i?)
(raise (make-exn:cancelled (raise (exn:cancelled
"Package Cancelled" "Package Cancelled"
(current-continuation-marks)))) (current-continuation-marks))))
i?))] i?))]
[tmp-plt-filename [tmp-plt-filename
(if install? (if install?
(make-temporary-file "tmp~a.plt") (make-temporary-file "tmp~a.rkt")
(put-file (put-file
(if size (if size
(format (format
@ -449,7 +444,7 @@ A test case:
(queue-callback (lambda () (semaphore-post wait-to-start))) (queue-callback (lambda () (semaphore-post wait-to-start)))
(send d show #t) (send d show #t)
(when exn (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)]) (let ([sema (make-semaphore 0)])
(when (and tmp-plt-filename install?) (when (and tmp-plt-filename install?)
(run-installer tmp-plt-filename (run-installer tmp-plt-filename
@ -458,13 +453,13 @@ A test case:
(yield sema)))) (yield sema))))
(raise (raise
(if tmp-plt-filename (if tmp-plt-filename
(make-exn:file-saved-instead (exn:file-saved-instead
(if install? (if install?
(string-constant package-was-installed) (string-constant package-was-installed)
(string-constant download-was-saved)) (string-constant download-was-saved))
(current-continuation-marks) (current-continuation-marks)
tmp-plt-filename) tmp-plt-filename)
(make-exn:cancelled "The download was cancelled." (exn:cancelled "The download was cancelled."
(current-continuation-marks)))))] (current-continuation-marks)))))]
[(or (and (url? url) [(or (and (url? url)
(not (null? (url-path url))) (not (null? (url-path url)))
@ -576,9 +571,9 @@ A test case:
;; build-html-error-message : exn -> string[html] ;; build-html-error-message : exn -> string[html]
(define ((build-html-error-message str) exn) (define ((build-html-error-message str) exn)
(string-append (string-append
"<html><head><title>Error Evaluating Scheme</title></head>" "<html><head><title>Error Evaluating Racket</title></head>"
"<body>" "<body>"
"<h2>Error Evaluating Scheme Code</h2>" "<h2>Error Evaluating Racket Code</h2>"
(format "<pre>\n~a\n</pre>" str) (format "<pre>\n~a\n</pre>" str)
"<p><p>" "<p><p>"
(format "<font color=\"red\">~a</font>" (format "<font color=\"red\">~a</font>"
@ -743,7 +738,7 @@ A test case:
(set-page (list e (or tag-pos 0) (send e last-position)) #t) (set-page (list e (or tag-pos 0) (send e last-position)) #t)
(when tag-pos (send e set-position tag-pos)))] (when tag-pos (send e set-position tag-pos)))]
[(exn? result) [(exn? result)
(message-box (string-constant drscheme) (message-box (string-constant drracket)
(exn-message result) (exn-message result)
tlw)] tlw)]
[else (void)])))))) [else (void)]))))))

368
pkgs/drracket/browser/private/option-snip.rkt
View File

@ -1,201 +1,199 @@
(module option-snip mzscheme #lang racket
(require mred (require racket/gui)
mzlib/class
mzlib/string)
(provide option-snip% (provide option-snip%
checkbox-snip%) checkbox-snip%)
(define inset 2) (define inset 2)
(define arrow-sep 5) (define arrow-sep 5)
(define arrow-height 5) (define arrow-height 5)
(define arrow (list (make-object point% 0 0) (define arrow (list (make-object point% 0 0)
(make-object point% arrow-height arrow-height) (make-object point% arrow-height arrow-height)
(make-object point% (* 2 arrow-height) 0))) (make-object point% (* 2 arrow-height) 0)))
(define arrow-cursor (make-object cursor% 'arrow)) (define arrow-cursor (make-object cursor% 'arrow))
(define option-snip% (define option-snip%
(class snip% (class snip%
(inherit get-admin set-snipclass set-count get-style get-flags set-flags) (inherit get-admin set-snipclass set-count get-style get-flags set-flags)
(init-field [options null]) (init-field [options null])
(define w #f) (define w #f)
(define h #f) (define h #f)
(define d #f) (define d #f)
(define current-option #f) (define current-option #f)
(define look-for-option #f) ; a box when we're looking (in case we're looking for #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) (define/public (add-option o v)
(set! options (append options (list (cons o v)))) (set! options (append options (list (cons o v))))
(when (and look-for-option (when (and look-for-option
(equal? v (unbox look-for-option))) (equal? v (unbox look-for-option)))
(set! current-option (cons o v))) (set! current-option (cons o v)))
(set! w #f) (set! w #f)
(set! h #f) (set! h #f)
(let ([a (get-admin)]) (let ([a (get-admin)])
(when a (when a
(send a resized this #t)))) (send a resized this #t))))
(define/public (get-value) (define/public (get-value)
(with-handlers ([exn:fail? (lambda (x) #f)]) (with-handlers ([exn:fail? (lambda (x) #f)])
(cdr (or current-option (cdr (or current-option
(car options))))) (car options)))))
(define/public (set-value v) (define/public (set-value v)
(let ([o (ormap (lambda (o) (and (equal? v (cdr o)) o)) options)]) (let ([o (ormap (lambda (o) (and (equal? v (cdr o)) o)) options)])
(if o (if o
(set! current-option o) (set! current-option o)
(set! look-for-option (box v))))) (set! look-for-option (box v)))))
(override* (override*
[get-extent ; called by an editor to get the snip's size [get-extent ; called by an editor to get the snip's size
(lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox) (lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox)
(unless w (unless w
(let ([font (send (get-style) get-font)]) (let ([font (send (get-style) get-font)])
(let ([w+h+ds (let ([w+h+ds
(map (lambda (o) (map (lambda (o)
(let-values ([(tw th td ta) (send dc get-text-extent (car o) font)]) (let-values ([(tw th td ta) (send dc get-text-extent (car o) font)])
(list tw th td))) (list tw th td)))
options)]) options)])
(if (null? w+h+ds) (if (null? w+h+ds)
(begin (begin
(set! w 10) (set! w 10)
(set! h 10) (set! h 10)
(set! d 2)) (set! d 2))
(begin (begin
(set! w (+ (* 2 inset) arrow-sep 2 (* 2 arrow-height) (apply max (map car w+h+ds)))) (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! h (+ (* 2 inset) 1 (apply max arrow-height (map cadr w+h+ds))))
(set! d (+ inset 1 (apply max (map caddr w+h+ds))))))))) (set! d (+ inset 1 (apply max (map caddr w+h+ds)))))))))
(when hbox (when hbox
(set-box! hbox h)) (set-box! hbox h))
(when wbox (when wbox
(set-box! wbox w)) (set-box! wbox w))
(when descentbox (when descentbox
(set-box! descentbox d)) (set-box! descentbox d))
(when spacebox (when spacebox
(set-box! spacebox 0)) (set-box! spacebox 0))
(when rspacebox (when rspacebox
(set-box! rspacebox 0)) (set-box! rspacebox 0))
(when lspacebox (when lspacebox
(set-box! lspacebox 0)))] (set-box! lspacebox 0)))]
[draw ; called by an editor to draw the snip [draw ; called by an editor to draw the snip
(lambda (dc x y . other) (lambda (dc x y . other)
(unless w (unless w
(get-extent dc x y #f #f #f #f #f #f)) (get-extent dc x y #f #f #f #f #f #f))
(send dc draw-rectangle x y (sub1 w) (sub1 h)) (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 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)) (send dc draw-line (+ x w -1) (+ y 1) (+ x w -1) (+ y h -1))
(let ([pen (send dc get-pen)] (let ([pen (send dc get-pen)]
[brush (send dc get-brush)]) [brush (send dc get-brush)])
(send dc set-brush (send the-brush-list find-or-create-brush (send pen get-color) 'solid)) (send dc set-brush (send the-brush-list find-or-create-brush (send pen get-color) 'solid))
(send dc draw-polygon arrow (send dc draw-polygon arrow
(+ x (- w 2 inset (* 2 arrow-height))) (+ x (- w 2 inset (* 2 arrow-height)))
(+ y (/ (- h arrow-height) 2))) (+ y (/ (- h arrow-height) 2)))
(send dc set-brush brush)) (send dc set-brush brush))
(unless (null? options) (unless (null? options)
(send dc draw-text (car (or current-option (car options))) (+ x inset) (+ y inset))))] (send dc draw-text (car (or current-option (car options))) (+ x inset) (+ y inset))))]
[copy [copy
(lambda () (lambda ()
(make-object option-snip% options))] (make-object option-snip% options))]
[size-cache-invalid [size-cache-invalid
(lambda () (set! w #f) (set! h #f))] (lambda () (set! w #f) (set! h #f))]
[on-event (lambda (dc x y editorx editory event) [on-event (lambda (dc x y editorx editory event)
(when (send event button-down?) (when (send event button-down?)
(let ([popup (make-object popup-menu%)]) (let ([popup (make-object popup-menu%)])
(for-each (lambda (o) (for-each (lambda (o)
(make-object menu-item% (car o) popup (make-object menu-item% (car o) popup
(lambda (i e) (lambda (i e)
(set! current-option o) (set! current-option o)
(let ([a (get-admin)]) (let ([a (get-admin)])
(when a (when a
(send a needs-update this 0 0 w h)))))) (send a needs-update this 0 0 w h))))))
options) options)
(let ([a (get-admin)]) (let ([a (get-admin)])
(when a (when a
(send a popup-menu popup this 0 0))))))] (send a popup-menu popup this 0 0))))))]
[adjust-cursor (lambda (dc x y editorx editory event) [adjust-cursor (lambda (dc x y editorx editory event)
arrow-cursor)]) arrow-cursor)])
(super-instantiate ()) (super-instantiate ())
(set-flags (cons 'handles-events (get-flags))) (set-flags (cons 'handles-events (get-flags)))
(set-count 1))) (set-count 1)))
(define cb-width 12) (define cb-width 12)
(define cb-height 12) (define cb-height 12)
(define checkbox-snip% (define checkbox-snip%
(class snip% (class snip%
(inherit get-admin set-snipclass set-count get-style get-flags set-flags) (inherit get-admin set-snipclass set-count get-style get-flags set-flags)
(init-field [checked? #f]) (init-field [checked? #f])
(define tracking? #f) (define tracking? #f)
(define hit? #f) (define hit? #f)
(define w cb-width) (define w cb-width)
(define h cb-height) (define h cb-height)
(define/public (get-value) checked?) (define/public (get-value) checked?)
(override* (override*
[get-extent ; called by an editor to get the snip's size [get-extent ; called by an editor to get the snip's size
(lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox) (lambda (dc x y wbox hbox descentbox spacebox lspacebox rspacebox)
(when hbox (when hbox
(set-box! hbox h)) (set-box! hbox h))
(when wbox (when wbox
(set-box! wbox w)) (set-box! wbox w))
(when descentbox (when descentbox
(set-box! descentbox 0)) (set-box! descentbox 0))
(when spacebox (when spacebox
(set-box! spacebox 0)) (set-box! spacebox 0))
(when rspacebox (when rspacebox
(set-box! rspacebox 0)) (set-box! rspacebox 0))
(when lspacebox (when lspacebox
(set-box! lspacebox 0)))] (set-box! lspacebox 0)))]
[draw ; called by an editor to draw the snip [draw ; called by an editor to draw the snip
(lambda (dc x y . other) (lambda (dc x y . other)
(send dc draw-rectangle x y w h) (send dc draw-rectangle x y w h)
(when tracking? (when tracking?
(send dc draw-rectangle (+ x 1) (+ y 1) (- w 2) (- h 2))) (send dc draw-rectangle (+ x 1) (+ y 1) (- w 2) (- h 2)))
(when (or (and (not hit?) checked?) (when (or (and (not hit?) checked?)
(and hit? (not checked?))) (and hit? (not checked?)))
(send dc draw-line x y (+ x w -1) (+ y h -1)) (send dc draw-line x y (+ x w -1) (+ y h -1))
(send dc draw-line x (+ y h -1) (+ x w -1) y)))] (send dc draw-line x (+ y h -1) (+ x w -1) y)))]
[copy [copy
(lambda () (lambda ()
(make-object checkbox-snip% checked?))] (make-object checkbox-snip% checked?))]
[on-event (lambda (dc x y editorx editory event) [on-event (lambda (dc x y editorx editory event)
(when (send event button-down?) (when (send event button-down?)
(set! tracking? #t) (set! tracking? #t)
(refresh) (refresh)
(set! hit? #f)) (set! hit? #f))
(if (or (send event button-down?) (if (or (send event button-down?)
(and tracking? (send event dragging?)) (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?))) (and tracking? (send event button-up?)))
(if (and (<= 0 (- (send event get-x) x)) (set! tracking? #f)
(<= 0 (- (send event get-y) y))) (when hit?
(when (not hit?) (set! hit? #f)
(set! hit? #t) (set! checked? (not checked?)))
(refresh)) (refresh)))]
(when hit? [adjust-cursor (lambda (dc x y editorx editory event)
(set! hit? #f) arrow-cursor)])
(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) (define/private (refresh)
(let ([a (get-admin)]) (let ([a (get-admin)])
(when a (when a
(send a needs-update this 0 0 w h)))) (send a needs-update this 0 0 w h))))
(super-instantiate ()) (super-instantiate ())
(set-flags (cons 'handles-events (get-flags))) (set-flags (cons 'handles-events (get-flags)))
(set-count 1)))) (set-count 1)))

84
pkgs/drracket/browser/private/sig.rkt
View File

@ -1,57 +1,57 @@
(module sig scheme/base #lang racket
(require scheme/unit) (require racket/unit)
(provide relative-btree^ (provide relative-btree^
bullet-export^ bullet-export^
hyper^ hyper^
html-export^ html-export^
html^) html^)
(define-signature html-export^ (define-signature html-export^
(html-img-ok (html-img-ok
html-eval-ok html-eval-ok
image-map-snip%)) image-map-snip%))
(define-signature html^ extends html-export^ (define-signature html^ extends html-export^
(html-convert (html-convert
html-status-handler)) html-status-handler))
(define-signature bullet-export^ (define-signature bullet-export^
(bullet-size)) (bullet-size))
(define-signature hyper^ (define-signature hyper^
(open-url (open-url
(struct exn:file-saved-instead (pathname)) (struct exn:file-saved-instead (pathname) #:omit-constructor)
(struct exn:cancelled ()) (struct exn:cancelled () #:omit-constructor)
hyper-text<%> hyper-text<%>
hyper-text-mixin hyper-text-mixin
hyper-text% hyper-text%
hyper-canvas-mixin hyper-canvas-mixin
hyper-canvas% hyper-canvas%
hyper-panel<%> hyper-panel<%>
hyper-panel-mixin hyper-panel-mixin
hyper-panel% hyper-panel%
hyper-frame<%> hyper-frame<%>
hyper-frame-mixin hyper-frame-mixin
hyper-frame% hyper-frame%
hyper-no-show-frame-mixin hyper-no-show-frame-mixin
hyper-no-show-frame% hyper-no-show-frame%
editor->page editor->page
page->editor)) page->editor))
(define-signature relative-btree^ (define-signature relative-btree^
(make-btree (make-btree
btree-get btree-get
btree-put! btree-put!
btree-shift! btree-shift!
btree-for-each btree-for-each
btree-map))) btree-map))

27
pkgs/drracket/browser/tool.rkt
View File

@ -1,15 +1,16 @@
(module tool mzscheme #lang racket
(require browser/external (require (only-in "external.rkt" install-help-browser-preference-panel)
mzlib/unit racket/unit
drscheme/tool) drracket/tool)
(provide tool@) (provide tool@)
;; to add a preference pannel to drscheme that sets the browser preference ;; to add a preference pannel to drracket that sets the browser preference
(define tool@ (define tool@
(unit (unit
(import drscheme:tool^) (import drracket:tool^)
(export drscheme:tool-exports^) (export drracket:tool-exports^)
(define phase1 void)
(define phase2 void)
(install-help-browser-preference-panel)))) (define (phase1) (void))
(define (phase2) (void))
(install-help-browser-preference-panel)))

1
pkgs/string-constants-lib/string-constants/private/danish-string-constants.rkt
View File

@ -106,6 +106,7 @@ please adhere to these guidelines:
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "Ok") (ok "Ok")
(cancel "Fortryd") (cancel "Fortryd")
(abort "Afbryd") (abort "Afbryd")

1
pkgs/string-constants-lib/string-constants/private/dutch-string-constants.rkt
View File

@ -19,6 +19,7 @@
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK") (ok "OK")
(cancel "Annuleren") (cancel "Annuleren")
(untitled "Naamloos") (untitled "Naamloos")

1
pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
View File

@ -106,6 +106,7 @@ please adhere to these guidelines:
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK") (ok "OK")
(cancel "Cancel") (cancel "Cancel")
(abort "Abort") (abort "Abort")

1
pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt
View File

@ -106,6 +106,7 @@
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK") (ok "OK")
(cancel "Annuler") (cancel "Annuler")
(abort "Abandonner") (abort "Abandonner")

1
pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt
View File

@ -13,6 +13,7 @@
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK") (ok "OK")
;; We can't use "Abbrechen" here because that's much closer in ;; We can't use "Abbrechen" here because that's much closer in
;; meaning to "abort", and it appears in dialogs saying "Quit?" "OK" ;; meaning to "abort", and it appears in dialogs saying "Quit?" "OK"

1
pkgs/string-constants-lib/string-constants/private/japanese-string-constants.rkt
View File

@ -106,6 +106,7 @@ please adhere to these guidelines:
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK") (ok "OK")
(cancel "キャンセル") (cancel "キャンセル")
(abort "中止") (abort "中止")

1
pkgs/string-constants-lib/string-constants/private/korean-string-constants.rkt
View File

@ -24,6 +24,7 @@
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "확인") (ok "확인")
(cancel "취소") (cancel "취소")
(abort "중단") (abort "중단")

1
pkgs/string-constants-lib/string-constants/private/portuguese-string-constants.rkt
View File

@ -106,6 +106,7 @@ please adhere to these guidelines:
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK") (ok "OK")
(cancel "Cancelar") (cancel "Cancelar")
(abort "Abortar") (abort "Abortar")

1
pkgs/string-constants-lib/string-constants/private/russian-string-constants.rkt
View File

@ -106,6 +106,7 @@ please adhere to these guidelines:
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK") (ok "OK")
(cancel "Отмена") (cancel "Отмена")
(abort "Отмена") (abort "Отмена")

1
pkgs/string-constants-lib/string-constants/private/simplified-chinese-string-constants.rkt
View File

@ -33,6 +33,7 @@
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "确定") (ok "确定")
(cancel "取消") (cancel "取消")
(abort "中止") (abort "中止")

1
pkgs/string-constants-lib/string-constants/private/spanish-string-constants.rkt
View File

@ -16,6 +16,7 @@
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK") (ok "OK")
(cancel "Cancelar") (cancel "Cancelar")
(abort "Abortar") (abort "Abortar")

2
pkgs/string-constants-lib/string-constants/private/traditional-chinese-string-constants.rkt
View File

@ -16,6 +16,8 @@
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "確定") (ok "確定")
(cancel "取消") (cancel "取消")
(abort "中止") (abort "中止")

1
pkgs/string-constants-lib/string-constants/private/ukrainian-string-constants.rkt
View File

@ -106,6 +106,7 @@ please adhere to these guidelines:
;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :) ;;; general purpose (DrRacket is hereby a word in every language, by decree of Robby :)
(plt "PLT") (plt "PLT")
(drscheme "DrRacket") (drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK") (ok "OK")
(cancel "Скасувати") (cancel "Скасувати")
(abort "Скасувати") (abort "Скасувати")