#lang scheme/base
(require net/url
scheme/contract
(file "../javascript/render.ss")
(file "../javascript/struct.ss")
(file "struct-internal.ss"))
(define (quotable-value->string val [pretty? #t])
(cond [(string? val) val]
[(symbol? val) (symbol->string val)]
[(bytes? val) (bytes->string/utf-8 val)]
[(number? val) (number->string val)]
[(boolean? val) (if val "yes" "no")]
[(url? val) (url->string val)]
[(javascript? val) (if pretty?
(javascript->pretty-string val)
(javascript->string val))]
[else (error (format "Expected val, received ~s." val))]))
(define (preserve-singletons? tag)
(and (memq tag '(script div p ul li span th td a iframe)) #t))
(define (attributes->raw attr+attrs)
(define (do-single-attribute attr)
(define val (attribute-value attr))
(make-raw (list (format " ~a=\"~a\""
(attribute-name attr)
(if (raw? val)
(raw-data val)
(let ([out (open-output-string)])
(display-string (quotable-value->string (atom-data val) #f) out)
(get-output-string out)))))))
(if (attribute? attr+attrs)
(do-single-attribute attr+attrs)
(make-block (map do-single-attribute attr+attrs))))
(define (quote-javascript-attribute-value val)
(if (javascript? val)
(javascript->string val)
val))
(define (display-string str out)
(define len (string-length str))
(let loop ([i 0])
(when (< i len)
(let ([char (string-ref str i)])
(case char
[(#\&) (display "&" out)]
[(#\") (display """ out)]
[(#\<) (display "<" out)]
[(#\>) (display ">" out)]
[else (display char out)]))
(loop (add1 i)))))
(provide/contract
[quotable-value->string (->* (quotable-value?) (boolean?) string?)]
[preserve-singletons? (-> symbol? boolean?)]
[attributes->raw (-> (or/c attribute? (listof attribute?)) (or/c raw? block?))]
[quote-javascript-attribute-value (-> quotable-value? quotable-value?)]
[display-string (-> string? output-port? void?)])