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

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

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

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

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

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

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

@ -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{<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
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]{
<A MZSCHEME="|This goes nowhere.|">Nowhere</A>
<A RACKET="|This goes nowhere.|">Nowhere</A>
}
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{<A MZSCHEME=sexpr>...</A>} form executes the expression when
the user clicks, the @litchar{MZSCHEME} expression in a comment is
@litchar{RACKET=sexpr} specially. Whereas the
@litchar{<A RACKET=sexpr>...</A>} 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]{
<!-- 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
@ -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{<A MZSCHEME="expr">...</A>} tag and
@litchar{<! MZSCHEME="expr">} comments (see above). Evaluates the
Called to handle the @litchar{<A RACKET="expr">...</A>} tag and
@litchar{<! RACKET="expr">} 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

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

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

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

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

143
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
(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)

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

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

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

@ -1,3 +1,3 @@
#lang scheme/base
#lang racket/base
(require "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")
@ -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)])

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

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

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

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

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

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

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

@ -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)
"<A MZSCHEME= ...> disabled"))))))
"<A RACKET= ...> 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
"<html><head><title>Error Evaluating Scheme</title></head>"
"<html><head><title>Error Evaluating Racket</title></head>"
"<body>"
"<h2>Error Evaluating Scheme Code</h2>"
"<h2>Error Evaluating Racket Code</h2>"
(format "<pre>\n~a\n</pre>" str)
"<p><p>"
(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)
(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)]))))))

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

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

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

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

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

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

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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "Ok")
(cancel "Fortryd")
(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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK")
(cancel "Annuleren")
(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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK")
(cancel "Cancel")
(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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK")
(cancel "Annuler")
(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 :)
(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"

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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK")
(cancel "キャンセル")
(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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "확인")
(cancel "취소")
(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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK")
(cancel "Cancelar")
(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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK")
(cancel "Отмена")
(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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "确定")
(cancel "取消")
(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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK")
(cancel "Cancelar")
(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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "確定")
(cancel "取消")
(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 :)
(plt "PLT")
(drscheme "DrRacket")
(drracket "DrRacket")
(ok "OK")
(cancel "Скасувати")
(abort "Скасувати")