
(module html mzscheme
  (require (lib "unitsig.ss")
           "sig.ss"
           (lib "mred-sig.ss" "mred")
           (lib "file.ss")
           (lib "etc.ss")
           (lib "list.ss")
           (lib "string.ss")
           (lib "port.ss")
           (lib "url-sig.ss" "net")
           (lib "url-structs.ss" "net")
	   (only (lib "html.ss" "html") read-html-as-xml)
	   (only (lib "html.ss" "html") read-html-comments)
	   (only (lib "html.ss" "html") use-html-spec)
	   (all-except (lib "xml.ss" "xml") read-comments)
           (lib "class.ss")
	   "bullet.ss"
	   "option-snip.ss"
	   "entity-names.ss")

  (provide html@)

  (define html@
    (unit/sig html^
      (import mred^
              net:url^)
      
      ;; 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* ([upath (url-path url)]
                     [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 active-select))
      (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
                                              "<font color=\"red\">Error during &lt;!-- MZSCHEME=... --&gt;: <i>~a</i></font>"
                                              (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]
                       
                       [insert 
                        (lambda (what)
                          (a-text-insert what (current-pos)))]
                       
                       [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 (opt-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)))
                             ;; The call to `string' here should be removed. It
                             ;; was here to avoid a v299.6 bug.
                             (insert (string (integer->char e)))
                             void]
                            [(<= 913 e 969)
                             (let ([lp (current-pos)])
                               (insert (string (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 <li>), 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)))))))))
