#lang scheme/unit
(require "sig.ss"
(lib "mred-sig.ss" "mred")
scheme/file
mzlib/port
net/url-sig
(only-in (lib "html.ss" "html")
read-html-as-xml read-html-comments use-html-spec)
(except-in (lib "xml.ss" "xml") read-comments)
mzlib/class
"bullet.ss"
"option-snip.ss"
"entity-names.ss")
(import mred^ url^)
(export html^)
(init-depend mred^)
;; CACHE
(define NUM-CACHED 10)
(define cached (make-vector 10 'no-image))
(define cached-name (make-vector 10 #f)) ; string or #f
(define cached-use (make-vector 10 0))
(define html-status-handler
(make-parameter
void
(lambda (f)
(unless (and (procedure? f)
(procedure-arity-includes? f 1))
(raise-type-error 'html-status-handler
"procedure of arity 1"
f))
f)))
(define (status . args)
((html-status-handler) (apply format args)))
(define status-stack (make-parameter null))
;; load-status : boolean string (union #f url) -> void
(define (load-status push? what url)
(let ([s (format "Loading ~a ~a..."
what
(if url
(trim 150 (url->string url))
"unknown url"))])
(status-stack (cons s (if push? (status-stack) null)))
(status "~a" s)))
(define (pop-status)
(status-stack (cdr (status-stack)))
(status "~a" (car (status-stack))))
(define (trim len s)
(if ((string-length s) . <= . len)
s
(string-append (substring s 0 (- len 4)) " ...")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Imap maps
;;
(define-struct image-map-rect (href left top right bottom))
(define finger-cursor (make-object cursor% 'arrow))
(define image-map-snip%
(class image-snip%
(init-field html-text)
(field [key "#key"])
(define/public (set-key k) (set! key k))
(define/public (get-key) key)
(field [rects null])
(define/public (set-rects rs) (set! rects rs))
(inherit get-admin)
(define/private (find-rect x y)
(let loop ([rects rects])
(cond
[(null? rects) #f]
[else
(let ([rect (car rects)])
(if (and (<= (image-map-rect-left rect) x (image-map-rect-right rect))
(<= (image-map-rect-top rect) y (image-map-rect-bottom rect)))
rect
(loop (cdr rects))))])))
;; add-area : string (listof number) string -> void
;; currently only supports rect shapes
(define/public (add-area shape coords href)
(when (and (equal? shape "rect")
(= 4 (length coords)))
(let ([x1 (car coords)]
[y1 (cadr coords)]
[x2 (caddr coords)]
[y2 (cadddr coords)])
(set! rects (cons (make-image-map-rect
href
(min x1 x2)
(min y1 y2)
(max x1 x2)
(max y1 y2))
rects)))))
(define/override (on-event dc x y editor-x editor-y evt)
(when (send evt button-up?)
(let* ([snipx (- (send evt get-x) x)]
[snipy (- (send evt get-y) y)]
[rect (find-rect snipx snipy)])
(when rect
(send html-text post-url (image-map-rect-href rect)))))
(super on-event dc x y editor-x editor-y evt))
(define/override (adjust-cursor dc x y editor-x editor-y evt)
(let ([snipx (- (send evt get-x) x)]
[snipy (- (send evt get-y) y)])
(if (find-rect snipx snipy)
finger-cursor
#f)))
;; warning: buggy. This doesn't actually copy the bitmap
;; over because there's no get-bitmap method for image-snip%
;; at the time of this writing.
(define/override (copy)
(let ([cp (new image-map-snip% (html-text html-text))])
(send cp set-key key)
(send cp set-rects rects)))
(super-make-object)
(inherit set-flags get-flags)
(set-flags (cons 'handles-events (get-flags)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Hardwired Scheme colorization; should come from a .css file
;;
(define (make-scheme-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))])
(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")])
(send d set-style-on 'italic)
d))
(define current-style-class (make-parameter null))
(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 '("navigation")) navigation-delta]
[else #f])))
(define (sub-path? a b)
(cond
[(null? b) #t]
[(null? a) #f]
[else (and (equal? (car a) (car b))
(sub-path? (cdr a) (cdr b)))]))
(define (with-style-class class thunk)
(if class
(parameterize ([current-style-class (cons class (current-style-class))])
(thunk))
(thunk)))
(define (lookup-span-class-delta class) (lookup-class-delta class))
(define re:hexcolor
(regexp "^#([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])([0-9a-fA-F][0-9a-fA-F])$"))
(define color-string->color
(lambda (str)
(let ([m (regexp-match re:hexcolor str)])
(if m
(make-object color%
(string->number (cadr m) 16)
(string->number (caddr m) 16)
(string->number (cadddr m) 16))
(send the-color-database find-color str)))))
(define html-eval-ok (make-parameter #t))
(define html-img-ok (make-parameter #t))
(define (get-bitmap-from-url url)
(if (html-img-ok)
(let ([tmp-filename (make-temporary-file "mredimg~a")])
(load-status #t "image" url)
(call-with-output-file* tmp-filename
(lambda (op)
(with-handlers ([exn:fail?
(lambda (x)
(printf "exn.9 ~s\n" (and (exn? x)
(exn-message x)))
(void))])
(call/input-url
url
get-pure-port
(lambda (ip)
(copy-port ip op)))))
'truncate)
(pop-status)
(let ([bitmap (make-object bitmap% tmp-filename)])
(with-handlers ([exn:fail?
(lambda (x)
(message-box "Warning"
(format "Could not delete file ~s~n~n~a"
tmp-filename
(if (exn? x)
(exn-message x)
x))))])
(delete-file tmp-filename))
(if (send bitmap ok?)
bitmap
#f)))
#f))
;; cache-bitmap : string -> (is-a?/c bitmap%)
(define (cache-bitmap url)
(let ([url-string (url->string url)])
(let loop ([n 0])
(cond
[(= n NUM-CACHED)
;; Look for item to uncache
(vector-set! cached-use 0 (max 0 (sub1 (vector-ref cached-use 0))))
(let ([m (let loop ([n 1][m (vector-ref cached-use 0)])
(if (= n NUM-CACHED)
m
(begin
(vector-set! cached-use n (max 0 (sub1 (vector-ref cached-use n))))
(loop (add1 n) (min m (vector-ref cached-use n))))))])
(let loop ([n 0])
(if (= (vector-ref cached-use n) m)
(let ([bitmap (get-bitmap-from-url url)])
(cond
[bitmap
(vector-set! cached n bitmap)
(vector-set! cached-name n url-string)
(vector-set! cached-use n 5)
bitmap]
[else #f]))
(loop (add1 n)))))]
[(equal? url-string (vector-ref cached-name n))
(vector-set! cached-use n (min 10 (add1 (vector-ref cached-use n))))
(vector-ref cached n)]
[else
(loop (add1 n))]))))
(define (update-image-maps image-map-snips image-maps)
(for-each
(lambda (image-map-snip)
(let ([image-map-key (send image-map-snip get-key)])
(let loop ([image-maps image-maps])
(cond
[(null? image-maps) (void)]
[else
(let* ([image-map (car image-maps)]
[name (get-field image-map 'name)])
(if (and name
(equal? (format "#~a" name)
(send image-map-snip get-key)))
(find/add-areas image-map-snip image-map)
(loop (cdr image-maps))))]))))
image-map-snips))
(define (find/add-areas image-map-snip image-map)
(let loop ([sexp image-map])
(cond
[(and (pair? sexp)
(eq? (car sexp) 'area)
(pair? (cdr sexp)))
(add-area image-map-snip (cadr sexp))
(loop (cddr sexp))]
[(pair? sexp)
(loop (car sexp))
(loop (cdr sexp))]
[else (void)])))
;; add-area : snip (listof (list sym string))[assoc] -> void
;; the second arg type is actually `any', but if it
;; matches the above, it is interprted propoerly;
;; otherwise silently nothing happens.
(define (add-area image-map-snip sexp)
(let ([shape #f]
[coords #f]
[href #f])
(let loop ([sexp sexp])
(cond
[(pair? sexp)
(let ([fst (car sexp)])
(when (and (pair? fst)
(symbol? (car fst))
(pair? (cdr fst))
(string? (cadr fst)))
(case (car fst)
[(shape) (set! shape (cadr fst))]
[(coords) (set! coords (cadr fst))]
[(href) (set! href (cadr fst))]
[else (void)]))
(loop (cdr sexp)))]
[else (void)]))
(when (and shape coords href)
(let ([p-coords (parse-coords coords)])
(when p-coords
(send image-map-snip add-area shape p-coords href))))))
;; parse-coords : string -> (listof number)
;; separates out a bunch of comma separated numbers in a string
;; into a list of scheme numbers
(define (parse-coords str)
(let loop ([str str])
(cond
[(regexp-match #rx"^[ \t\n]*([0-9]+)[ \t\n]*,(.*)$" str)
=>
(lambda (m)
(let ([num (cadr m)]
[rst (caddr m)])
(cons (string->number num)
(loop rst))))]
[(regexp-match #rx"^[ \t\n]*([0-9]+)[ \t\n]*" str)
=>
(lambda (m)
(list (string->number (cadr m))))]
[else null])))
(define (make-get-field str)
(let ([s (apply
string-append
(map
(lambda (c)
(format "[~a~a]"
(char-upcase c)
(char-downcase c)))
(string->list str)))]
[spc (string #\space #\tab #\newline #\return #\vtab)])
(let ([re:plain (regexp (format "(^|[~a])~a[~a]*=[~a]*([^~a]*)" spc s spc spc spc))]
[re:quote (regexp (format "(^|[~a])~a[~a]*=[~a]*\"([^\"]*)\"" spc s spc spc))])
(lambda (args)
(let ([m (or (regexp-match re:quote args)
(regexp-match re:plain args))])
(and m (caddr m)))))))
(define (get-field e name)
(let ([a (assq name (cadr e))])
(and a (cadr a))))
(define get-mzscheme-arg
(let ([get-mz (make-get-field "mzscheme")])
(lambda (str)
(let ([v (get-mz str)])
(and v (filter-mzscheme v))))))
(define filter-mzscheme
(lambda (v)
(regexp-replace* "[|]" v "\"")))
(define face-list #f)
(define default-font (make-object font% 12 'default))
(define re:quot (regexp "[&][qQ][uU][oO][tT][;]"))
(define re:amp (regexp "[&][aA][mM][pP][;]"))
(define re:empty (regexp (format "^[ ~c]*$" (integer->char 160))))
(define-struct form (action target method [parts #:mutable] [active-select #:mutable]))
(define (protect-chars s)
(apply string-append
(map (lambda (c)
(if (or (char-alphabetic? c)
(char-numeric? c))
(string c)
(format "%~a"
(let ([s (format "0~x" (or (char->integer c) 65))])
(substring s (- (string-length s) 2) (string-length s))))))
(string->list s))))
(define re:true (regexp-quote "true" #f))
(define (true? s) (regexp-match re:true s))
(define verbatim-tags '(listing xmp plaintext))
(define preformatted-tags '(pre))
(define exact-whitespace-tags (append verbatim-tags
preformatted-tags))
(define comment-tags '(script))
(define atomic-tags '(p br hr li dd dt img html meta link input))
(define enum-tags '(ul dl ol menu))
(define space-eating-tags '(title p div center br h1 h2 h3 h4
li dt dd
ul ol dl menu
samp kbd pre blockquote
table tr td))
(define whitespace-string "[ \t\n\r\v\f]+")
(define re:whitespace (regexp whitespace-string))
(define re:starting-whitespace (regexp (format "^~a" whitespace-string)))
(define re:ending-whitespace (regexp (format "~a$" whitespace-string)))
(define re:leading-newline (regexp "^(\r|\n|(\r\n))"))
(define (remove-leading-newline c)
(cond
[(string? c)
(let ([s (regexp-match-positions re:leading-newline c)])
(cond
[(and s (= (cdar s) (length s)))
;; It's all newline:
(values "" #t)]
[s (values (substring c (cdar s) (string-length c)) #t)]
[else (values c #t)]))]
[(pair? c)
(let loop ([b (cddr c)][accum null])
(if (null? b)
(values (list* (car c) (cadr c) (reverse accum)) #f)
(let-values ([(d done?) (remove-leading-newline (car b))])
(if done?
(values (list* (car c) (cadr c) (append (reverse accum)
(list d)
(cdr b)))
#t)
(loop (cdr b) (cons d accum))))))]
[else (values c #f)]))
(define (fixup-whitespace c leading-ok?)
(cond
[(string? c)
(let ([s (regexp-match-positions re:starting-whitespace c)]
[e (regexp-match-positions re:ending-whitespace c)])
(if (and s e
(= (caar s) (caar e)))
;; It's all whitespace:
(if leading-ok?
(values " " #f)
(values "" #f))
;; Normal case:
(values
(string-append
(if (and s leading-ok?) " " "")
(regexp-replace* re:whitespace
(substring c
(if s
(cdar s)
0)
(if e
(caar e)
(string-length c)))
" ")
(if e " " ""))
(not e))))]
[(symbol? c) (values c #t)]
[(number? c) (values c #t)]
[(comment? c)
(let ([code (get-mzscheme-arg (comment-text c))])
(if code
(let ([s (with-handlers ([exn:fail?
(lambda (exn)
(format
"Error during <!-- MZSCHEME=... -->: ~a"
(if (exn? exn)
(exn-message exn)
(format "~s" exn))))])
(if (html-eval-ok)
(eval (read (open-input-string code)))
(error "disabled")))])
(if (string? s)
(let ([content (read-html (open-input-string s))])
(fixup-whitespace content leading-ok?))
(values "" leading-ok?)))
(values "" leading-ok?)))]
[(pi? c) (values "" leading-ok?)] ;; processing instruction
[else (let ([tag (car c)])
(if (memq tag exact-whitespace-tags)
(let-values ([(s done?) (remove-leading-newline c)])
(values s #f))
(let-values ([(body leading-ok?)
(let loop ([l (cddr c)][leading-ok?
(and leading-ok?
(not (memq tag space-eating-tags)))])
(if (null? l)
(values null leading-ok?)
(let*-values ([(f l-ok?)
(fixup-whitespace (car l) leading-ok?)]
[(r l-ok?)
(loop (cdr l) l-ok?)])
(values (cons f r) l-ok?))))])
(values
(list*
tag
(cadr c) ; attributes
body)
(and leading-ok?
(not (memq tag space-eating-tags)))))))]))
(define (read-html a-port)
(let* ([xml (parameterize ([read-html-comments #t]
[use-html-spec #f])
(read-html-as-xml a-port))]
[xexpr `(html () ,@(map xml->xexpr xml))])
xexpr))
(define (parse-html a-port)
(let ([raw (read-html a-port)])
(let-values ([(v ?) (fixup-whitespace raw #f)])
v)))
(define html-convert
(lambda (a-port a-text)
(let ([content (parse-html a-port)])
(with-method ([a-text-insert (a-text insert)]
[current-pos (a-text last-position)]
[delete (a-text delete)]
[get-character (a-text get-character)]
[change-style (a-text change-style)])
(letrec ([image-map-snips null]
[image-maps null]
[html-basic-style
(let ([sl (send a-text get-style-list)])
(or (send sl find-named-style "Html Standard")
(send sl find-named-style "Standard")
(send sl find-named-style "Basic")))]
;; inserts
[insert
(λ (what)
(let ([pos-before (current-pos)])
(a-text-insert what pos-before)
(let ([pos-after (current-pos)])
(change-style html-basic-style pos-before pos-after))))]
[insert-newlines
(lambda (num forced-lines para-base)
(let ([num (max num forced-lines)])
(unless (zero? num)
(let loop ([pos (current-pos)][num num])
(unless (or (zero? num) (<= pos para-base))
(let ([c (get-character (sub1 pos))])
(if (eq? c #\newline)
(loop (sub1 pos) (sub1 num))
(insert (make-string num #\newline)))))))))]
[backover-newlines
(lambda (pos base)
(if (= pos base)
base
(let ([c (get-character (sub1 pos))])
(if (eq? c #\newline)
(backover-newlines (sub1 pos) base)
pos))))]
[whitespaces (string #\space #\tab #\newline #\return)]
[delta:fixed (make-object style-delta% 'change-family 'modern)]
[delta:default-face (make-object style-delta% 'change-family 'default)]
[delta:bold (make-object style-delta% 'change-bold)]
[delta:underline (make-object style-delta% 'change-underline #t)]
[delta:italic (make-object style-delta% 'change-italic)]
[delta:h1 (let ([d (make-object style-delta% 'change-bold)])
(send d set-size-mult 2.0)
d)]
[delta:h2 (let ([d (make-object style-delta% 'change-bold)])
(send d set-size-mult 1.5)
d)]
[delta:h3 (let ([d (make-object style-delta% 'change-bold)])
(send d set-size-mult 1.2)
d)]
[delta:h4 (make-object style-delta% 'change-bold)]
[delta:subscript (let ([d (make-object style-delta%)])
(send d set-alignment-on 'bottom)
(send d set-size-mult 0.8)
d)]
[delta:superscript (let ([d (make-object style-delta%)])
(send d set-alignment-on 'top)
(send d set-size-mult 0.8)
d)]
[delta:small (let ([d (make-object style-delta%)])
(send d set-size-mult 0.75)
d)]
[delta:center (make-object style-delta% 'change-alignment 'center)]
[delta:symbol (make-object style-delta% 'change-family 'symbol)]
[html-error
(lambda args
(when #f ; treat them all as ignored warnings
(apply error 'html args)))]
[re:transparent #rx"[Tt][Rr][Aa][Nn][Ss][Pp][Aa][Rr][Ee][Nn][Tt]"]
[parse-image-source
(lambda (s)
(let ([src (get-field s 'src)]
[base-url (send a-text get-url)])
(and src
(with-handlers ([exn:fail? (lambda (x) #f)])
(if base-url
(combine-url/relative base-url src)
(string->url src))))))]
[unescape
(lambda (s)
(apply string-append
(map (lambda (x)
(if (pcdata? x)
(pcdata-string x)
""))
(read-html-as-xml
(open-input-string s)))))]
[parse-href
(let ([href-error
(lambda (s)
(html-error "bad reference in ~s" s))])
(lambda (s)
(let* ([url-string
(cond
[(get-field s 'href)
=> (lambda (str)
(if (string=? str "")
(begin (href-error s)
#f)
(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))))]
[parse-font
(let ([face-regexp (regexp "([^,]*), *(.*)")])
(lambda (args)
(let ([size-string (get-field args 'size)]
[face-string (get-field args 'face)]
[color-string (get-field args 'color)]
[bg-color-string (get-field args 'bgcolor)])
(let ([size
(and size-string
(let* ([n (string->number size-string)])
(and n
(integer? n)
(<= -127 n 127)
(cond
[(char=? #\+ (string-ref size-string 0))
(make-object style-delta% 'change-bigger n)]
[(negative? n)
(make-object style-delta% 'change-smaller (- n))]
[else
(cond
[(n . < . 2)
(make-object style-delta% 'change-smaller (- 2 n))]
[(n . > . 2)
(make-object style-delta% 'change-bigger (- n 2))]
[else #f])]))))]
[face (and face-string
(or
(and (string=? face-string "monospace")
(make-object style-delta% 'change-family 'modern))
(let ([f (let loop ([f face-string])
(let ([m (regexp-match face-regexp f)]
[try-face (lambda (s)
(unless face-list
(set! face-list (get-face-list)))
(ormap
(lambda (s-norm)
(and (string-ci=? s s-norm)
s-norm))
face-list))])
(if m
(or (try-face (cadr m))
(loop (caddr m)))
(try-face f))))])
(and f
(let ([d (make-object style-delta%)])
(send d set-delta-face f))))))]
[color (let ([clr (and color-string (color-string->color color-string))])
(and clr
(let ([d (make-object style-delta%)])
(send d set-delta-foreground clr))))]
[bg-color (let ([bg-clr (and bg-color-string
(color-string->color bg-color-string))])
(and bg-clr
(let ([d (make-object style-delta%)])
(send d set-delta-background bg-clr))))])
(let loop ([delta #f][l (list size face color bg-color)])
(cond
[(null? l) delta]
[(not (car l)) (loop delta (cdr l))]
[else (if delta
(loop (begin
(send delta collapse (car l))
delta)
(cdr l))
(loop (car l) (cdr l)))]))))))]
[make-unsupported
(lambda (tag args)
(let ([name (get-field args 'name)]
[type (get-field args 'type)])
(if (and (eq? tag 'input) type (string=? type "hidden"))
"" ; hidden input
(format "[~a~a NOT SUPPORTED]"
(if name
(format "~a " name)
"")
(case tag
[(select) "POPUP MENU"]
[(textarea) "TEXT AREA"]
[(input) (if type
(case (string->symbol type)
[(text) "TEXT FIELD"]
[else "BUTTON"])
"BUTTON")])))))]
[heading (lambda (delta forced-lines rest para-base)
(insert-newlines 2 forced-lines para-base)
(let-values ([(start-pos) (current-pos)]
[(r rfl) (rest)]
[(end-pos) (current-pos)])
(insert-newlines 2 rfl para-base)
(values
(lambda ()
(change-style delta start-pos end-pos)
(r))
rfl)))]
[styler (lambda (delta rest [drop-empty? #f])
(let*-values ([(start-pos) (current-pos)]
[(r rfl) (rest)]
[(end-pos) (current-pos)])
(if (and drop-empty?
(regexp-match re:empty (send a-text get-text start-pos end-pos)))
(begin
(delete start-pos end-pos)
(values void rfl))
(values
(lambda ()
(change-style delta start-pos end-pos)
(r))
rfl))))]
[maybe-bg-color (lambda (e rest drop-empty?)
(let* ([c (get-field e 'bgcolor)]
[color (and c (color-string->color c))])
(cond
[color
(styler (let ([d (make-object style-delta%)])
(send d set-delta-background color)
d)
rest
drop-empty?)]
[drop-empty?
(let*-values ([(start-pos) (current-pos)]
[(r rfl) (rest)]
[(end-pos) (current-pos)])
(values (if (regexp-match re:empty (send a-text get-text start-pos end-pos))
void
r)
rfl))]
[else
(rest)])))]
[para-aligner (lambda (alignment delta rest)
(let*-values ([(start-pos) (current-pos)]
[(r rfl) (rest)]
[(end-pos) (current-pos)])
(values
(lambda ()
(let ([last-para (send a-text position-paragraph
(backover-newlines end-pos start-pos))])
(let loop ([para (send a-text position-paragraph start-pos)])
(if (eq? alignment 'left-outdent)
(begin
(send a-text set-paragraph-alignment para 'left)
(send a-text set-paragraph-margins para 0 (* 2 (get-bullet-width)) 0))
(send a-text set-paragraph-alignment para alignment))
(when delta
(change-style delta start-pos end-pos))
(unless (= para last-para)
(loop (add1 para)))))
(r))
rfl)))]
;; translate-number : number -> void
[translate-number
(lambda (e)
(cond
[(and (not (= e #xFFFF))
(not (= e #xFFFE))
(not (<= #xD800 e #xDFFF))
(send default-font screen-glyph-exists? (integer->char e)))
(insert (integer->char e))
void]
[(<= 913 e 969)
(let ([lp (current-pos)])
(insert (integer->char (+ (- e 913) (char->integer #\A))))
(lambda ()
(change-style delta:symbol lp (+ lp 1))))]
;; poor ascii approximations. probably these
;; (and other) characters exist somewhere,
;; but I don't know where.
[(= e 160) (insert " ") void]
[(= e 338) (insert "OE") void]
[(= e 339) (insert "oe") void]
[(= e 732) (insert "~") void]
[(= e 710) (insert "^") void]
[(= e 8242) (insert "'") void]
[(= e 8243) (insert "''") void]
[(= e 8260) (insert "/") void]
[(= e 8722) (insert "-") void]
[(= e 8727) (insert "*") void]
[(= e 8764) (insert "~") void]
[(= e 8804) (insert "<") void]
[(= e 8805) (insert ">") void]
[(= e 8211) (insert "--") void]
[(= e 8212) (insert "---") void]
[else (insert (format "&#~a;" e))
void]))]
;; ========================================
;; This is the main formatting function.
;; It consumes:
;; e : xexpr - the HTML content
;; para-base : num - a marker for a paragraph start (e.g.,
;; the bullet for ), though the actual
;; paragraph start may be later
;; enum-depth : num - current depth of enumerations
;; The result is a function of no arguments that finalizes
;; the region for `e', which normally means applying font changes.
;; (The changes have to be applied outside-in, so that local
;; specifications override enclosing ones.)
;; Translate must not modify any existing text, and the
;; result function must not move any items.
[translate
(lambda (e para-base enum-depth forced-lines form)
(cond
[(string? e)
(let ([lp (current-pos)])
(insert e)
;; we change the style here directly
;; since we want this style to only appear
;; if the style is overridden by the context
(change-style delta:default-face
lp
(+ lp (string-length e)))
(values void
0))]
[(symbol? e)
(let ([a (entity-name->integer e)])
(if a
(values (translate-number a) 0)
(begin
(insert (format "&~a;" e))
(values void 0))))]
[(number? e)
(values (translate-number e) 0)]
[(or (comment? e) (pi? e)) (values void forced-lines)]
[else (let* ([tag (car e)]
[rest/base/depth/form/fl
(lambda (para-base enum-depth form forced-lines)
(let* ([p (foldl (lambda (x p)
(let-values ([(f fl) (translate x para-base enum-depth (car p) form)])
(cons fl (cons f (cdr p)))))
(cons forced-lines null)
(cddr e))]
[l (reverse (cdr p))])
(values (lambda ()
(map (lambda (f) (f)) l))
(car p))))]
[rest/base/depth
(lambda (para-base enum-depth)
(rest/base/depth/form/fl para-base enum-depth form forced-lines))]
[rest/form (lambda (form) (rest/base/depth/form/fl para-base enum-depth form forced-lines))]
[rest/form (lambda (form) (rest/base/depth/form/fl para-base enum-depth form forced-lines))]
[rest (lambda () (rest/base/depth/form/fl para-base enum-depth form forced-lines))]
[rest/fl (lambda (fl) (rest/base/depth/form/fl para-base enum-depth form fl))])
(case tag
[(title)
(let ([pos (current-pos)])
;; Render content
(rest)
(send a-text set-title (send a-text get-text pos (current-pos)))
(delete pos (current-pos)))
(values void forced-lines)]
[(a)
(let-values ([(url-string label scheme) (parse-href e)])
(let* ([style (get-field e 'style)]
[pos (current-pos)])
(let-values ([(r rfl) (rest)])
(let ([end-pos (current-pos)])
(cond
[url-string
(send a-text add-link pos end-pos (regexp-replace* re:amp url-string "\\&"))
;; might have a label, too:
(when label
(send a-text add-tag label pos))
(values
(lambda ()
(when (or (not style)
(not (regexp-match re:transparent style)))
(send a-text make-link-style pos end-pos))
(r))
rfl)]
[label
(send a-text add-tag label pos)
(values r rfl)]
[scheme
(send a-text add-scheme-callback pos end-pos scheme)
(values
(lambda ()
(when (or (not style)
(not (regexp-match re:transparent style)))
(send a-text make-link-style pos end-pos))
(r))
rfl)]
[else (values r rfl)])))))]
[(style) (values void forced-lines)]
[(h1) (heading delta:h1 forced-lines rest para-base)]
[(h2) (heading delta:h2 forced-lines rest para-base)]
[(h3) (heading delta:h3 forced-lines rest para-base)]
[(h4) (heading delta:h4 forced-lines rest para-base)]
[(b strong) (styler delta:bold rest)]
[(i em var dfn cite) (styler delta:italic rest)]
[(u) (styler delta:underline rest)]
[(sup) (styler delta:superscript rest)]
[(sub) (styler delta:subscript rest)]
[(small) (styler delta:small rest)]
[(font)
(let ([delta (parse-font e)])
(if delta
(styler delta rest)
(rest)))]
[(li dd dt)
(insert-newlines 1 forced-lines para-base)
(let ([pos (current-pos)]
[bullet? (eq? tag 'li)])
(when bullet?
(let ([before (current-pos)])
(insert (make-object bullet-snip% (sub1 enum-depth)))
(change-style (send (send a-text get-style-list) find-named-style "Standard")
before
(+ before 1))))
(let*-values ([(r rfl) (rest/base/depth (add1 pos) enum-depth)]
[(end-pos) (current-pos)])
(values
(lambda ()
(let ([end-para (send a-text position-paragraph
(backover-newlines end-pos pos))]
[left-margin (* 2 (get-bullet-width) enum-depth)])
(let loop ([para (send a-text position-paragraph pos)]
[first? #t])
(send a-text set-paragraph-margins
para
(if first?
(max 0 (- left-margin
(if bullet?
(get-bullet-width)
0)))
left-margin)
left-margin
0)
(unless (= para end-para)
(loop (add1 para) #f))))
(r))
rfl)))]
[(ul menu ol dl)
(insert-newlines (if (zero? enum-depth) 2 1) forced-lines para-base)
(let-values ([(r rfl)
(rest/base/depth para-base (add1 enum-depth))])
(insert-newlines (if (zero? enum-depth) 2 1) rfl para-base)
(values r rfl))]
[(p)
(insert-newlines 2 forced-lines para-base)
(let-values ([(r rfl) (rest)])
(insert-newlines 2 rfl para-base)
(values r rfl))]
[(blockquote)
(insert-newlines 2 forced-lines para-base)
(let*-values ([(pos) (current-pos)]
[(r rfl) (rest/base/depth para-base (add1 enum-depth))]
[(end-pos) (current-pos)])
(begin0
(values
(lambda ()
(let ([end-para (send a-text position-paragraph
(backover-newlines end-pos pos))]
[left-margin (* 2 (get-bullet-width) (add1 enum-depth))])
(let loop ([para (send a-text position-paragraph pos)])
(send a-text set-paragraph-margins
para
left-margin
left-margin
left-margin)
(unless (= para end-para)
(loop (add1 para)))))
(r))
rfl)
(insert-newlines 2 rfl para-base)))]
[(center)
(insert-newlines 2 forced-lines para-base)
(let-values ([(r rfl)
(para-aligner 'center #f rest)])
(insert-newlines 2 rfl para-base)
(values r rfl))]
[(div)
(insert-newlines 1 forced-lines para-base)
(let* ([align (get-field e 'align)]
[class (get-field e 'class)]
[delta (and class (lookup-class-delta class))])
(with-style-class
class
(lambda ()
(let-values ([(r rfl)
(cond
[(and (string? align) (string-ci=? align "center"))
(para-aligner 'center delta rest)]
[(and (string? align) (string-ci=? align "left"))
(para-aligner 'left delta rest)]
[(and (string? align) (string-ci=? align "left-outdent"))
(para-aligner 'left-outdent delta rest)]
[(or (and (string? align) (string-ci=? align "right"))
(and (string? class) (string-ci=? class "navigation")))
(para-aligner 'right delta rest)]
[delta
(styler delta rest)]
[else (rest)])])
(insert-newlines 1 rfl para-base)
(values r rfl)))))]
[(br)
(insert-newlines 1 (+ 1 forced-lines) para-base)
(rest/fl (+ forced-lines 1))]
[(table)
(insert-newlines 1 forced-lines para-base)
(let-values ([(r rfl)
(maybe-bg-color e rest #t)])
(insert-newlines 1 rfl para-base)
(values r (max 1 rfl)))]
[(tr)
(insert-newlines 1 forced-lines para-base)
(let-values ([(r rfl)
(maybe-bg-color e rest #t)])
(insert-newlines 1 rfl para-base)
(values r rfl))]
[(td)
(maybe-bg-color e rest #t)]
[(map)
(set! image-maps (cons e image-maps))
(rest)]
[(img)
(let* ([url (parse-image-source e)]
[alt (get-field e 'alt)]
[bitmap (and url (cache-bitmap url))]
[usemap (get-field e 'usemap)])
(cond
[(and bitmap usemap)
(let ([pos (current-pos)]
[image-map-snip (make-object image-map-snip% a-text)])
(send image-map-snip set-bitmap bitmap)
(send image-map-snip set-key usemap)
(insert image-map-snip)
(set! image-map-snips (cons image-map-snip image-map-snips))
(change-style delta:center pos (add1 pos)))]
[bitmap
(let ([pos (current-pos)])
(insert (make-object image-snip% bitmap))
(change-style delta:center pos (add1 pos)))]
[alt
(insert alt)]
[else
(let ([pos (current-pos)])
(insert (new image-snip%))
(change-style delta:center pos (add1 pos)))])
(rest))]
[(form)
(rest/form (make-form (get-field e 'action) (get-field e 'target) (get-field e 'method) null #f))]
[(input select textarea)
(let ([unsupported (make-unsupported tag e)]
[pos (current-pos)]
[type (let ([t (get-field e 'type)])
(and t (string->symbol t)))]
[send-form (lambda (add-self?)
(let ([post-string
(apply
string-append
(map (lambda (v)
(if (car v)
(format "~a=~a&"
(car v)
(protect-chars (or ((cdr v))
"?")))
""))
(form-parts form)))])
(send a-text post-url
(form-action form)
(string->bytes/utf-8
(if add-self?
;; Add this button
(format "~a~a=~a"
post-string
(get-field e 'name)
(protect-chars (get-field e 'value)))
;; remove trailing &
(substring post-string
0
(max 0 (sub1 (string-length post-string)))))))))])
(let-values ([(name cb get-val)
(cond
[(eq? tag 'select)
(let ([select (make-object option-snip%)])
(set-form-active-select! form select)
(insert select)
(values (get-field e 'name)
#f
(lambda ()
(send select get-value))))]
[(or (and (eq? tag 'input)
(or (not type) (eq? type 'text)))
(eq? tag 'textarea))
(let* ([text (make-object text%)]
[snip (make-object editor-snip% text)]
[size (get-field e 'size)]
[val (get-field e 'value)])
(let ([km (send text get-keymap)])
((current-text-keymap-initializer) km)
(unless (eq? tag 'textarea)
(send km add-function "send-form"
(lambda (t e)
(send-form #f)))
(send km map-function "enter" "send-form")))
(let ([width (* 10 (or (and size (string->number size))
25))])
(send text set-min-width width)
(send text set-max-width width))
(when val
(send text insert val))
(insert snip)
(values
(get-field e 'name)
#f
(lambda () (send text get-text))))]
[(and (eq? tag 'input)
(eq? type 'submit))
(insert (get-field e 'value))
(values
#f ; because we leave out this button when it's not pushed
(lambda ()
(send-form #t))
#f)]
[(and (eq? tag 'input)
(eq? type 'checkbox))
(let ([cb (make-object checkbox-snip% (true? (or (get-field e 'value) "false")))])
(insert cb)
(values
(get-field e 'name)
#f
(lambda () (if (send cb get-value)
"true"
"false"))))]
[(and (eq? tag 'input)
(eq? type 'hidden))
(values
(get-field e 'name)
#f
(lambda () (regexp-replace* re:quot (get-field e 'value) "\"")))]
[else
(insert unsupported)
(values #f #f #f)])])
(set-form-parts! form
(cons (cons name
(or get-val
(lambda ()
(get-field e 'value))))
(form-parts form)))
(let-values ([(r rfl) (rest)]
[(end-pos) (current-pos)])
(set-form-active-select! form #f)
(values
(lambda ()
(cond
[cb
(send a-text make-link-style pos end-pos)
(send a-text add-thunk-callback pos end-pos cb)]
[else
(change-style delta:default-face pos end-pos)])
(r))
rfl))))]
[(option)
(let-values ([(pos) (current-pos)]
[(r rfl) (rest)]
[(val) (get-field e 'value)]
[(selected?) (true? (or (get-field e 'selected)
"false"))]
[(end-pos) (current-pos)])
(let ([str (send a-text get-text pos end-pos)]
[select (form-active-select form)])
(delete pos end-pos)
(when select
(send select add-option str (or val str))
(when selected?
(send select set-value val)))
(values r rfl)))]
[(tt code samp kbd pre)
(when (memq tag '(pre))
(insert-newlines 2 forced-lines para-base))
(let-values ([(r rfl)
(let* ([class (get-field e 'class)]
[delta (and class (lookup-class-delta class))])
(with-style-class
class
(lambda ()
(styler (if delta
(let ([d (make-object style-delta% 'change-nothing)])
(send d copy delta)
(send d collapse delta:fixed)
d)
delta:fixed)
rest))))])
(when (memq tag '(pre))
(insert-newlines 2 rfl para-base))
(values r rfl))]
[(span)
(let* ([class (get-field e 'class)]
[delta (and class (lookup-class-delta class))])
(if delta
(styler delta rest)
(rest)))]
[else (rest)]))]))])
(load-status #f "page" (send a-text get-url))
(let-values ([(f fl) (translate content 0 0 0 (make-form #f #f #f null #f))])
(f))
(send a-text add-tag "top" 0)
(update-image-maps image-map-snips image-maps)
(send a-text set-position 0))))))