655 lines
16 KiB
Racket
655 lines
16 KiB
Racket
;;; style.ss
|
|
|
|
(module style mzscheme
|
|
(require mzlib/string)
|
|
(require "util.ss")
|
|
(require "properties.ss")
|
|
|
|
(provide
|
|
make-css-percentage
|
|
css-percentage?
|
|
css-percentage-num
|
|
make-css-length
|
|
css-length?
|
|
css-length-num
|
|
css-length-units
|
|
font-families->string
|
|
string->font-families
|
|
string->font-size
|
|
valid-css-length?
|
|
css-length->string
|
|
percentage-or-length?
|
|
percentage-or-length->string
|
|
make-bg-pos-getter
|
|
make-bg-pos-setter
|
|
make-element-getter
|
|
make-element-setter
|
|
make-pagebreak-getter
|
|
make-pagebreak-setter
|
|
list->background-position
|
|
border-width?
|
|
border-style->string
|
|
border-width->string
|
|
border->string
|
|
border-items->string
|
|
set-border-with-fun
|
|
string->border-item
|
|
make-border-getter
|
|
make-border-style-getter
|
|
make-border-style-setter
|
|
make-border-width-getter
|
|
make-border-width-setter
|
|
string->html-color
|
|
html-color->string
|
|
make-color-getter
|
|
make-color-setter
|
|
make-css-getter
|
|
make-css-setter
|
|
make-const-or-css-getter-maker
|
|
make-normal-or-css-getter
|
|
make-auto-or-css-getter
|
|
make-const-or-css-setter-maker
|
|
make-normal-or-css-setter
|
|
make-auto-or-css-setter
|
|
parse-string
|
|
parse-decoration
|
|
validated-string->symbols
|
|
string->list-style-item
|
|
list-style-item->string
|
|
string->background-position
|
|
string->margin
|
|
margin->string
|
|
string->padding
|
|
padding->string
|
|
url->string
|
|
string->url
|
|
clip-rect?
|
|
clip-rect->symbols)
|
|
|
|
(define-struct css-percentage (num))
|
|
(define-struct css-length (num units))
|
|
|
|
(define font-family->string
|
|
(lambda (ff)
|
|
(if (regexp-match ".* .*" ff) ; contains a space
|
|
(string-append "\"" ff "\"")
|
|
ff)))
|
|
|
|
(define font-families->string
|
|
(lambda (ffs)
|
|
(let loop ([ffs ffs])
|
|
(cond
|
|
[(null? ffs)
|
|
""]
|
|
[(null? (cdr ffs))
|
|
(font-family->string (car ffs))]
|
|
[else
|
|
(string-append (font-family->string (car ffs))
|
|
","
|
|
(loop (cdr ffs)))]))))
|
|
|
|
(define string->font-families
|
|
(lambda (s)
|
|
(let ([lst (string->list s)]
|
|
[build-curr
|
|
(lambda (cs)
|
|
(list->string (reverse (remove-ws cs))))])
|
|
(let loop ([lst lst]
|
|
[curr '()])
|
|
(cond
|
|
[(null? lst)
|
|
(if (null? curr)
|
|
'()
|
|
(list (build-curr curr)))]
|
|
[(char-ci=? #\, (car lst))
|
|
; strip leading whitespace
|
|
; start on new current word
|
|
(let ([tail (loop (remove-ws (cdr lst)) '())])
|
|
(if (null? curr)
|
|
tail
|
|
(cons (build-curr curr) tail)))]
|
|
[(member (car lst) '(#\" #\')) ; strip quotes
|
|
(loop (cdr lst) curr)]
|
|
[else
|
|
(loop (cdr lst) (cons (car lst) curr))])))))
|
|
|
|
(define (string->font-size s)
|
|
(let ([sym (string->symbol s)])
|
|
(cond
|
|
[(font-size? sym) sym]
|
|
[(parse-css-length (string->list s)) =>
|
|
(lambda (val-rest) (car val-rest))]
|
|
[else s])))
|
|
|
|
(define (valid-css-length? elt)
|
|
(and (css-length? elt)
|
|
(exact? (css-length-num elt))
|
|
(css-unit? (css-length-units elt))))
|
|
|
|
(define (css-length->string elt)
|
|
(string-append (number->string (css-length-num elt))
|
|
(symbol->string (css-length-units elt))))
|
|
|
|
(define percentage-or-length?
|
|
(lambda (elt)
|
|
(or (and (css-percentage? elt)
|
|
(exact? (css-percentage-num elt)))
|
|
(and (valid-css-length? elt)))))
|
|
|
|
(define percentage-or-length->string
|
|
(lambda (elt)
|
|
(cond
|
|
[(css-length? elt)
|
|
(css-length->string elt)]
|
|
[(css-percentage? elt)
|
|
(string-append (number->string (css-percentage-num elt)) "%")]
|
|
[else
|
|
(error "Not a CSS percentage or length: ~a" elt)])))
|
|
|
|
(define (make-bg-pos-getter elt f fname)
|
|
(lambda ()
|
|
(let ([pos (f elt)])
|
|
(when (empty-string? pos)
|
|
(empty-property-error fname))
|
|
(car (list->background-position (string->list pos))))))
|
|
|
|
(define (make-bg-pos-setter elt f pred? elts coord)
|
|
(lambda (pos)
|
|
(cond
|
|
[(pred? pos)
|
|
(f elt (symbol->string pos))]
|
|
[(percentage-or-length? pos)
|
|
(f elt (percentage-or-length->string pos))]
|
|
[else
|
|
(error
|
|
(format
|
|
(string-append
|
|
"set-background-position-~a!: "
|
|
"Expected value in ~a, "
|
|
"CSS length, or CSS percentage, "
|
|
"got ~a")
|
|
coord elts pos))])))
|
|
|
|
(define (make-element-getter elt getter name)
|
|
(lambda ()
|
|
(let ([s (getter elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error name)
|
|
(string->symbol s)))))
|
|
|
|
(define (make-element-setter elt pred? props f!)
|
|
(lambda (s)
|
|
(unless (pred? s)
|
|
(error
|
|
(format "Expected element of ~a, got: ~a"
|
|
props s)))
|
|
(f! elt (symbol->string s))))
|
|
|
|
(define (make-pagebreak-getter elt f)
|
|
(lambda ()
|
|
(let ([s (f elt)])
|
|
(if (empty-string? s)
|
|
'none
|
|
(string->symbol s)))))
|
|
|
|
(define (make-pagebreak-setter elt f! name)
|
|
(lambda (s)
|
|
(unless (pagebreak? s)
|
|
(error
|
|
(format "~a: Expected element of ~a, got: ~a"
|
|
name *page-breaks* s)))
|
|
(let ([str (if (eq? s 'none)
|
|
""
|
|
(symbol->string s))])
|
|
(f! elt str))))
|
|
|
|
(define (border-width? elt)
|
|
(or (memq elt *border-widths*)
|
|
(valid-css-length? elt)))
|
|
|
|
(define border-style->string symbol->string)
|
|
|
|
(define (border-width->string elt)
|
|
(if (css-length? elt)
|
|
(css-length->string elt)
|
|
(symbol->string elt)))
|
|
|
|
(define (border->string elt)
|
|
(cond
|
|
[(border-width? elt)
|
|
(border-width->string elt)]
|
|
[(border-style? elt)
|
|
(border-style->string elt)]
|
|
[(html-color? elt)
|
|
(html-color->string elt)]))
|
|
|
|
(define (border-items->string elts)
|
|
(fold-strings-with-spaces (map border->string elts)))
|
|
|
|
(define (set-border-with-fun elt cs f)
|
|
(for-each
|
|
(lambda (c)
|
|
(unless (or (border-width? c)
|
|
(border-style? c)
|
|
(html-color? c))
|
|
(error
|
|
(format
|
|
(string-append
|
|
"set-border!: expected nonempty list where each "
|
|
"element is either "
|
|
"a border width (one of '~a, or a CSS length), "
|
|
"a border style (one of '~a, or "
|
|
"an HTML color, got ~a")
|
|
*border-widths*
|
|
*border-styles*
|
|
c))))
|
|
cs)
|
|
(f elt (border-items->string cs)))
|
|
|
|
(define (string->border-item s)
|
|
(let ([sym (string->symbol s)])
|
|
(cond
|
|
;color
|
|
[(memq sym *html-colors*)
|
|
sym]
|
|
[(hex-digit-string? s)
|
|
s]
|
|
;style
|
|
[(memq sym *border-styles*)
|
|
sym]
|
|
;width
|
|
[(memq sym *border-widths*)
|
|
sym]
|
|
[(parse-css-length (string->list s)) => car]
|
|
;error
|
|
[else
|
|
(error (format "Expected border item, got: ~a" s))])))
|
|
|
|
(define (string->border-list s)
|
|
(map string->border-item (parse-string s)))
|
|
|
|
(define (make-border-getter elt f name)
|
|
(lambda ()
|
|
(let ([s (f elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error name)
|
|
(string->border-list s)))))
|
|
|
|
(define (make-border-style-getter elt f name)
|
|
(lambda ()
|
|
(let ([s (f elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error name)
|
|
(string->border-item s)))))
|
|
|
|
(define (make-border-style-setter elt f name)
|
|
(lambda (s)
|
|
(unless (border-style? s)
|
|
(error
|
|
(format "~a: Expected element of ~a, got ~a"
|
|
name *border-styles* s)))
|
|
(f elt (border-style->string s))))
|
|
|
|
(define (make-border-width-getter elt f name)
|
|
(lambda ()
|
|
(let ([s (f elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error name)
|
|
(string->border-item s)))))
|
|
|
|
(define (make-border-width-setter elt f name)
|
|
(lambda (s)
|
|
(unless (border-width? s)
|
|
(error
|
|
(format "~a: Expected element of ~a or CSS length, got ~a"
|
|
name *border-widths* s)))
|
|
(f elt (border->string s))))
|
|
|
|
(define (string->html-color s)
|
|
(if (char=? (string-ref s 0) #\#)
|
|
s
|
|
(string->symbol s)))
|
|
|
|
(define (html-color->string s)
|
|
(if (symbol? s)
|
|
(symbol->string s)
|
|
s))
|
|
|
|
(define (make-color-getter elt f name)
|
|
(lambda ()
|
|
(let ([s (f elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error name)
|
|
(string->html-color s)))))
|
|
|
|
(define (make-color-setter elt f name)
|
|
(lambda (s)
|
|
(unless
|
|
(html-color? s)
|
|
(error
|
|
(format "~a: Expected HTML color, got: ~a"
|
|
name s)))
|
|
(f elt (html-color->string s))))
|
|
|
|
(define (make-css-getter elt f fname)
|
|
(lambda ()
|
|
(let ([s (f elt)])
|
|
(when (empty-string? s)
|
|
(empty-property-error fname))
|
|
(cond
|
|
[(parse-css-length (string->list s)) => car]
|
|
[else s]))))
|
|
|
|
(define (make-css-setter elt f fname)
|
|
(lambda (css)
|
|
(let ([s (cond
|
|
[(percentage-or-length? css)
|
|
(percentage-or-length->string css)]
|
|
[else
|
|
(error
|
|
(string-append
|
|
fname ": Expected "
|
|
"CSS length or percentage, got")
|
|
css)])])
|
|
(f elt s))))
|
|
|
|
(define (make-const-or-css-getter-maker c)
|
|
(lambda (elt f fname)
|
|
(lambda ()
|
|
(let ([s (f elt)])
|
|
(when (empty-string? s)
|
|
(empty-property-error fname))
|
|
(cond
|
|
[(string=? (symbol->string c) s) c]
|
|
[(parse-css-length (string->list s)) => car]
|
|
[else s])))))
|
|
|
|
(define make-normal-or-css-getter
|
|
(make-const-or-css-getter-maker 'normal))
|
|
|
|
(define make-auto-or-css-getter
|
|
(make-const-or-css-getter-maker 'auto))
|
|
|
|
(define (make-const-or-css-setter-maker c)
|
|
(lambda (elt f fname)
|
|
(lambda (v)
|
|
(let ([s (cond
|
|
[(eq? v c) (symbol->string c)]
|
|
[(percentage-or-length? v)
|
|
(percentage-or-length->string v)]
|
|
[else
|
|
(error
|
|
(string-append
|
|
fname ": Expected 'normal, "
|
|
"CSS length or percentage, got")
|
|
v)])])
|
|
(f elt s)))))
|
|
|
|
(define make-normal-or-css-setter
|
|
(make-const-or-css-setter-maker 'normal))
|
|
|
|
(define make-auto-or-css-setter
|
|
(make-const-or-css-setter-maker 'auto))
|
|
|
|
(define (html-color? s)
|
|
(or (hex-color-string? s)
|
|
(memq s *html-colors*)))
|
|
|
|
(define parse-number ; returns number, rest of list
|
|
(lambda (lst)
|
|
(let loop ([num? #f]
|
|
[seen-dot #f]
|
|
[digits '()]
|
|
[lst lst])
|
|
(let ([c (car lst)])
|
|
(cond
|
|
[(char-numeric? c)
|
|
(loop #t seen-dot (cons c digits) (cdr lst))]
|
|
[(eq? c #\.)
|
|
(if seen-dot
|
|
(error "More than one period in number")
|
|
(loop #t #t (cons c digits) (cdr lst)))]
|
|
[else
|
|
(if num?
|
|
(cons (string->number
|
|
(list->string (reverse digits))) lst)
|
|
#f)])))))
|
|
|
|
; (listof char) -> (cons symbol (listof char))
|
|
(define parse-units ; returns unit symbol, rest of list
|
|
(lambda (lst)
|
|
(let* ([sym-rest
|
|
(let loop ([word '()]
|
|
[lst lst])
|
|
(cond
|
|
[(or (null? lst) (char-whitespace? (car lst)))
|
|
(cons (string->symbol (list->string (reverse word)))
|
|
lst)]
|
|
[else
|
|
(loop (cons (car lst) word) (cdr lst))]))]
|
|
[sym (car sym-rest)]
|
|
[rst (cdr sym-rest)])
|
|
(if (or (eq? sym '%) (css-unit? sym))
|
|
(cons sym rst)
|
|
(error "Unable to parse units")))))
|
|
|
|
; (listof symbols) -> (listof char) -> (union #f (listof symbol))
|
|
(define make-words-parser
|
|
(lambda (syms)
|
|
(lambda (lst)
|
|
(let loop ([word '()]
|
|
[lst lst])
|
|
(cond
|
|
[(or (null? lst)
|
|
(char-whitespace? (car lst)))
|
|
(let ([sym (string->symbol (list->string (reverse word)))])
|
|
(if (memq sym syms)
|
|
(cons sym lst)
|
|
#f))]
|
|
[else
|
|
(loop (cons (car lst) word) (cdr lst))])))))
|
|
|
|
(define parse-horizontal
|
|
(make-words-parser *horizontals*))
|
|
|
|
(define parse-vertical
|
|
(make-words-parser *verticals*))
|
|
|
|
(define parse-string ; string -> (listof string)
|
|
(lambda (s)
|
|
(let ([tack-on-word
|
|
(lambda (word words)
|
|
(if (null? word)
|
|
words
|
|
(cons (list->string (reverse word)) words)))])
|
|
(let loop ([word '()]
|
|
[words '()]
|
|
[lst (string->list s)])
|
|
(cond
|
|
[(null? lst)
|
|
(reverse (tack-on-word word words))]
|
|
[(char-whitespace? (car lst))
|
|
(loop '() (tack-on-word word words) (cdr lst))]
|
|
[else
|
|
(loop (cons (car lst) word) words (cdr lst))])))))
|
|
|
|
(define (parse-css-length lst)
|
|
(cond
|
|
[(parse-number lst) =>
|
|
(lambda (num-rest)
|
|
(let ([num (car num-rest)]
|
|
[rst (cdr num-rest)])
|
|
(cond
|
|
[(parse-units rst) =>
|
|
(lambda (unit-rest)
|
|
(let* ([units (car unit-rest)]
|
|
[val (if (eq? units '%)
|
|
(make-css-percentage num)
|
|
(make-css-length num units))])
|
|
(cons val (cdr unit-rest))))]
|
|
[else #f])))]
|
|
[else #f]))
|
|
|
|
(define parse-decoration
|
|
(make-words-parser *decorations*))
|
|
|
|
(define validated-string->symbols
|
|
(lambda (s funname parser)
|
|
(if (empty-string? s)
|
|
(empty-property-error funname)
|
|
(let ([lst (string->list s)])
|
|
(let loop ([lst lst]
|
|
[words '()])
|
|
(let ([word-rest (parser lst)])
|
|
(if word-rest
|
|
(loop (remove-ws (cdr word-rest))
|
|
(cons (car word-rest) words))
|
|
(reverse words))))))))
|
|
|
|
(define (string->list-style-item s)
|
|
(if (string-ci=? (substring s 0 4) "url(")
|
|
(url->string s)
|
|
(let ([sym (string->symbol s)])
|
|
(if (or (list-style-type? sym)
|
|
(list-style-position? sym))
|
|
sym
|
|
(error (format "Expected list-style item, got: ~a"
|
|
s))))))
|
|
|
|
(define (list-style-item->string s)
|
|
(cond
|
|
[(or (list-style-type? s)
|
|
(list-style-position? s))
|
|
(symbol->string s)]
|
|
[(string? s)
|
|
(string->url s)]
|
|
[else
|
|
(error
|
|
(format "Expected list-style item, got: ~a"))]))
|
|
|
|
(define string->background-position
|
|
(lambda (s)
|
|
(let ([bp (list->background-position (string->list s))])
|
|
(case (length bp)
|
|
[(1) (car bp)]
|
|
[(2) bp]
|
|
[else "Invalid background position"]))))
|
|
|
|
(define list->background-position
|
|
(lambda (lst)
|
|
(cond
|
|
[(null? lst) '()]
|
|
[(parse-css-length lst) =>
|
|
(lambda (val-rest)
|
|
(cons (car val-rest)
|
|
(list->background-position
|
|
(remove-ws (cdr val-rest)))))]
|
|
[(parse-horizontal lst) =>
|
|
(lambda (x-rest)
|
|
(cons (car x-rest)
|
|
(list->background-position (remove-ws (cdr x-rest)))))]
|
|
[(parse-vertical lst) =>
|
|
(lambda (y-rest)
|
|
(cons (car y-rest)
|
|
(list->background-position (remove-ws (cdr y-rest)))))]
|
|
[else
|
|
(error "Can't parse background-position")])))
|
|
|
|
(define (make-css-parser loop lst)
|
|
(lambda (num-rest)
|
|
(let ([num (car num-rest)]
|
|
[rst (cdr num-rest)])
|
|
(let* ([unit-rest (parse-units rst)]
|
|
[units (car unit-rest)]
|
|
[the-val (if (eq? units '%)
|
|
(make-css-percentage num)
|
|
(make-css-length num units))])
|
|
(cons the-val (loop (cdr lst)))))))
|
|
|
|
(define string->margin
|
|
(lambda (s)
|
|
(let loop ([lst (parse-string s)])
|
|
(when (> (length lst) 4)
|
|
(error "Only four margin values allowed, got" s))
|
|
(cond
|
|
[(null? lst)
|
|
'()]
|
|
[(string=? (car lst) "auto")
|
|
(cons 'auto (loop (cdr lst)))]
|
|
[(parse-number (string->list (car lst))) =>
|
|
(make-css-parser loop lst)]
|
|
[else
|
|
(error (string-append
|
|
"Expected margin string with up to four of "
|
|
"CSS length, CSS percentage, or auto. Got")
|
|
s)]))))
|
|
|
|
(define string->padding
|
|
(lambda (s)
|
|
(let loop ([lst (parse-string s)])
|
|
(when (> (length lst) 4)
|
|
(error "Only four padding values allowed, got" s))
|
|
(cond
|
|
[(null? lst)
|
|
'()]
|
|
[(parse-number (string->list (car lst))) =>
|
|
(make-css-parser loop lst)]
|
|
[else
|
|
(error (string-append
|
|
"Expected padding string with up to four of "
|
|
"CSS lengths or CSS percentages. Got")
|
|
s)]))))
|
|
|
|
(define string->percentage-or-length
|
|
(lambda (s)
|
|
(let ([lst (string->list s)])
|
|
(cond
|
|
[(parse-number (string->list (car lst))) =>
|
|
(lambda (num-rest)
|
|
(let ([num (car num-rest)]
|
|
[rst (cdr num-rest)])
|
|
(let* ([unit-rest (parse-units rst)]
|
|
[units (car unit-rest)]
|
|
[the-val (if (eq? units '%)
|
|
(make-css-percentage num)
|
|
(make-css-length num units))])
|
|
the-val)))]
|
|
[else
|
|
(error "Expected string with percentage or length, got ~a"
|
|
s)]))))
|
|
|
|
(define margin-item->string
|
|
(lambda (item)
|
|
(cond
|
|
[(eq? item 'auto)
|
|
"auto"]
|
|
[else
|
|
(percentage-or-length->string item)])))
|
|
|
|
(define margin->string
|
|
(map-to-string margin-item->string))
|
|
|
|
(define padding->string
|
|
(map-to-string percentage-or-length->string))
|
|
|
|
(define (url->string s)
|
|
; "url(foo)" -> "foo"
|
|
(substring s 4 (sub1 (string-length s))))
|
|
|
|
(define (string->url s)
|
|
; ""foo" -> url(foo)"
|
|
(string-append "url(" s ")"))
|
|
|
|
(define (clip-rect? s)
|
|
(string-ci=?
|
|
(substring s 0 5) "rect("))
|
|
|
|
(define (clip-rect->symbols s)
|
|
(map (lambda (s)
|
|
(if (string=? s "auto")
|
|
'auto
|
|
(car (parse-css-length (string->list s)))))
|
|
(parse-string (substring s 5 (sub1 (string-length s)))))))
|
|
|
|
|