2609 lines
72 KiB
Scheme
2609 lines
72 KiB
Scheme
;; mysterx.ss
|
|
|
|
(module mysterx mzscheme
|
|
|
|
; private mysterx modules
|
|
|
|
(require (prefix mxprims: "private/mxmain.ss"))
|
|
(require (prefix style: "private/style.ss"))
|
|
(require "private/filter.ss")
|
|
(require "private/properties.ss")
|
|
(require "private/util.ss")
|
|
|
|
; mzlib
|
|
|
|
(require (prefix mzlib: mzlib/list))
|
|
(require mzlib/string)
|
|
(require mzlib/class)
|
|
(require net/url)
|
|
(require mzlib/etc)
|
|
(require mzlib/thread)
|
|
|
|
; exports
|
|
|
|
(provide
|
|
mx-browser%
|
|
mx-element%
|
|
mx-document<%>
|
|
mx-event<%>
|
|
mx-version
|
|
block-while-browsers
|
|
com-invoke
|
|
com-get-property
|
|
com-set-property!
|
|
com-methods
|
|
com-get-properties
|
|
com-set-properties
|
|
com-events
|
|
com-method-type
|
|
com-get-property-type
|
|
com-set-property-type
|
|
com-event-type
|
|
com-object-type
|
|
com-add-ref
|
|
com-ref-count
|
|
com-is-a?
|
|
com-help
|
|
com-register-event-handler
|
|
com-unregister-event-handler
|
|
com-all-coclasses
|
|
com-all-controls
|
|
coclass->html
|
|
progid->html
|
|
cocreate-instance-from-coclass
|
|
cci/coclass
|
|
cocreate-instance-from-progid
|
|
cci/progid
|
|
com-get-active-object-from-coclass
|
|
gao/coclass
|
|
coclass
|
|
progid
|
|
set-coclass!
|
|
set-coclass-from-progid!
|
|
com-object-eq?
|
|
com-omit
|
|
make-css-percentage
|
|
css-percentage?
|
|
css-percentage-num
|
|
make-css-length
|
|
css-length?
|
|
css-length-num
|
|
css-length-units
|
|
com-date->date
|
|
date->com-date
|
|
com-date?
|
|
com-currency?
|
|
com-currency->number
|
|
number->com-currency
|
|
com-scode?
|
|
com-scode->number
|
|
number->com-scode
|
|
com-object?
|
|
com-iunknown?
|
|
%%initialize-dotnet-runtime)
|
|
|
|
(define mx-version mxprims:mx-version)
|
|
(define block-while-browsers mxprims:block-while-browsers)
|
|
(define com-invoke mxprims:com-invoke)
|
|
(define com-method-type mxprims:com-method-type)
|
|
(define com-get-property-type mxprims:com-get-property-type)
|
|
(define com-set-property-type mxprims:com-set-property-type)
|
|
(define com-event-type mxprims:com-event-type)
|
|
(define com-object-type mxprims:com-object-type)
|
|
(define com-add-ref mxprims:com-add-ref)
|
|
(define com-ref-count mxprims:com-ref-count)
|
|
(define com-is-a? mxprims:com-is-a?)
|
|
(define com-currency? mxprims:com-currency?)
|
|
(define number->com-currency mxprims:number->com-currency)
|
|
(define com-currency->number mxprims:com-currency->number)
|
|
(define com-date? mxprims:com-date?)
|
|
(define com-date->date mxprims:com-date->date)
|
|
(define date->com-date mxprims:date->com-date)
|
|
(define com-scode? mxprims:com-scode?)
|
|
(define number->com-scode mxprims:number->com-scode)
|
|
(define com-scode->number mxprims:com-scode->number)
|
|
(define com-object? mxprims:com-object?)
|
|
(define com-iunknown? mxprims:com-iunknown?)
|
|
(define com-help mxprims:com-help)
|
|
(define com-register-event-handler mxprims:com-register-event-handler)
|
|
(define com-unregister-event-handler mxprims:com-unregister-event-handler)
|
|
(define coclass->html mxprims:coclass->html)
|
|
(define progid->html mxprims:progid->html)
|
|
(define cocreate-instance-from-coclass mxprims:cocreate-instance-from-coclass)
|
|
(define cci/coclass cocreate-instance-from-coclass)
|
|
(define cocreate-instance-from-progid mxprims:cocreate-instance-from-progid)
|
|
(define cci/progid cocreate-instance-from-progid)
|
|
(define com-get-active-object-from-coclass mxprims:com-get-active-object-from-coclass)
|
|
(define gao/coclass com-get-active-object-from-coclass)
|
|
(define coclass mxprims:coclass)
|
|
(define progid mxprims:progid)
|
|
(define set-coclass! mxprims:set-coclass!)
|
|
(define set-coclass-from-progid! mxprims:set-coclass-from-progid!)
|
|
(define com-object-eq? mxprims:com-object-eq?)
|
|
(define com-omit mxprims:com-omit)
|
|
|
|
(define %%initialize-dotnet-runtime mxprims:%%initialize-dotnet-runtime)
|
|
|
|
;; sort results of "reflection" results
|
|
|
|
(define (alphabetize lst)
|
|
(mzlib:sort lst string-ci<?))
|
|
|
|
(define (make-sorted-fun f)
|
|
(lambda (obj)
|
|
(alphabetize (f obj))))
|
|
|
|
(define com-methods (make-sorted-fun mxprims:com-methods))
|
|
(define com-get-properties (make-sorted-fun mxprims:com-get-properties))
|
|
(define com-set-properties (make-sorted-fun mxprims:com-set-properties))
|
|
(define com-events (make-sorted-fun mxprims:com-events))
|
|
|
|
(define (make-sorted-thunk f)
|
|
(lambda ()
|
|
(alphabetize (f))))
|
|
|
|
(define com-all-coclasses
|
|
(make-sorted-thunk mxprims:com-all-coclasses))
|
|
(define com-all-controls
|
|
(make-sorted-thunk mxprims:com-all-controls))
|
|
|
|
;; property getter/setter
|
|
|
|
(define (get-item-property obj item)
|
|
(cond
|
|
[(and (pair? item)
|
|
(string? (car item)))
|
|
(apply mxprims:com-get-property obj item)]
|
|
[(string? item)
|
|
(mxprims:com-get-property obj item)]
|
|
[else
|
|
(error "For COM property, expected a string or a list with a string a the first element")]))
|
|
|
|
(define (com-get-property obj . path)
|
|
(cond
|
|
[(null? path)
|
|
(error 'com-get-property
|
|
"Expected one or more properties (strings or lists with a string as the first element)")]
|
|
[(null? (cdr path))
|
|
(get-item-property obj (car path))]
|
|
[else (apply com-get-property
|
|
(get-item-property obj (car path))
|
|
(cdr path))]))
|
|
|
|
(define (com-set-property! obj . path-and-value)
|
|
(cond
|
|
[(or (null? path-and-value)
|
|
(null? (cdr path-and-value)))
|
|
(error 'com-set-property!
|
|
"Expected one or more properties (strings or lists with a string as the first element) and a value")]
|
|
[(null? (cddr path-and-value)) ; (property value)
|
|
(let ([ppty (car path-and-value)]
|
|
[val (cadr path-and-value)])
|
|
(if (pair? ppty)
|
|
(if (string? (car ppty))
|
|
(apply mxprims:com-set-property! obj
|
|
(append ppty (list val)))
|
|
(error 'com-set-property!
|
|
"Indexed property must be a list with a string (property name) as the first element"))
|
|
(mxprims:com-set-property! obj ppty val)))]
|
|
[else (apply com-set-property!
|
|
(get-item-property obj (car path-and-value))
|
|
(cdr path-and-value))]))
|
|
|
|
;; style-related procedures
|
|
|
|
(define make-css-percentage style:make-css-percentage)
|
|
(define css-percentage? style:css-percentage?)
|
|
(define css-percentage-num style:css-percentage-num)
|
|
(define make-css-length style:make-css-length)
|
|
(define css-length? style:css-length?)
|
|
(define css-length-num style:css-length-num)
|
|
(define css-length-units style:css-length-units)
|
|
|
|
(define html-sem (make-semaphore 1)) ; protects HTML insertions
|
|
(define html-wait (lambda () (semaphore-wait html-sem)))
|
|
(define html-post (lambda () (semaphore-post html-sem)))
|
|
|
|
(define mx-element%
|
|
(class object% (init document dhtml-element)
|
|
(public
|
|
insert-html
|
|
append-html
|
|
replace-html
|
|
get-html
|
|
get-text
|
|
insert-text
|
|
append-text
|
|
insert-object-from-coclass
|
|
append-object-from-coclass
|
|
insert-object-from-progid
|
|
append-object-from-progid
|
|
focus
|
|
selection
|
|
set-selection!
|
|
attribute
|
|
set-attribute!
|
|
click
|
|
tag
|
|
font-family
|
|
font-family-native
|
|
set-font-family!
|
|
set-font-family-native!
|
|
font-style
|
|
font-style-native
|
|
set-font-style!
|
|
set-font-style-native!
|
|
font-variant
|
|
font-variant-native
|
|
set-font-variant!
|
|
set-font-variant-native!
|
|
font-weight
|
|
font-weight-native
|
|
set-font-weight!
|
|
set-font-weight-native!
|
|
font-native
|
|
set-font-native!
|
|
background-native
|
|
set-background-native!
|
|
background-attachment
|
|
background-attachment-native
|
|
set-background-attachment!
|
|
set-background-attachment-native!
|
|
background-image
|
|
background-image-native
|
|
set-background-image!
|
|
set-background-image-native!
|
|
background-repeat
|
|
background-repeat-native
|
|
set-background-repeat!
|
|
set-background-repeat-native!
|
|
background-position
|
|
background-position-native
|
|
set-background-position!
|
|
set-background-position-native!
|
|
text-decoration
|
|
text-decoration-native
|
|
set-text-decoration!
|
|
set-text-decoration-native!
|
|
text-transform
|
|
text-transform-native
|
|
set-text-transform!
|
|
set-text-transform-native!
|
|
text-align
|
|
text-align-native
|
|
set-text-align!
|
|
set-text-align-native!
|
|
margin
|
|
margin-native
|
|
set-margin!
|
|
set-margin-native!
|
|
padding
|
|
padding-native
|
|
set-padding!
|
|
set-padding-native!
|
|
border
|
|
border-native
|
|
set-border!
|
|
set-border-native!
|
|
border-top-native
|
|
set-border-top!
|
|
set-border-top-native!
|
|
border-bottom-native
|
|
set-border-bottom!
|
|
set-border-bottom-native!
|
|
border-left-native
|
|
set-border-left!
|
|
set-border-left-native!
|
|
border-right-native
|
|
border-top
|
|
border-bottom
|
|
border-left
|
|
border-right
|
|
set-border-right!
|
|
set-border-right-native!
|
|
border-color
|
|
border-color-native
|
|
set-border-color!
|
|
set-border-color-native!
|
|
border-width
|
|
border-width-native
|
|
set-border-width!
|
|
set-border-width-native!
|
|
border-style
|
|
border-style-native
|
|
set-border-style!
|
|
set-border-style-native!
|
|
border-top-style
|
|
border-top-style-native
|
|
set-border-top-style!
|
|
set-border-top-style-native!
|
|
border-bottom-style
|
|
border-bottom-style-native
|
|
set-border-bottom-style!
|
|
set-border-bottom-style-native!
|
|
border-left-style
|
|
border-left-style-native
|
|
set-border-left-style!
|
|
set-border-left-style-native!
|
|
border-right-style
|
|
border-right-style-native
|
|
set-border-right-style!
|
|
set-border-right-style-native!
|
|
border-top-color
|
|
border-top-color-native!
|
|
set-border-top-color!
|
|
set-border-top-color-native!
|
|
border-bottom-color
|
|
border-bottom-color-native
|
|
set-border-bottom-color!
|
|
set-border-bottom-color-native!
|
|
border-left-color
|
|
border-left-color-native
|
|
set-border-left-color!
|
|
set-border-left-color-native!
|
|
border-right-color
|
|
border-right-color-native
|
|
set-border-right-color!
|
|
set-border-right-color-native!
|
|
border-top-width
|
|
border-top-width-native
|
|
set-border-top-width!
|
|
set-border-top-width-native!
|
|
border-bottom-width
|
|
border-bottom-width-native
|
|
set-border-bottom-width!
|
|
set-border-bottom-width-native!
|
|
border-left-width
|
|
border-left-width-native
|
|
set-border-left-width!
|
|
set-border-left-width-native!
|
|
border-right-width
|
|
border-right-width-native
|
|
set-border-right-width!
|
|
set-border-right-width-native!
|
|
style-float
|
|
style-float-native
|
|
set-style-float!
|
|
set-style-float-native!
|
|
clear
|
|
clear-native
|
|
set-clear!
|
|
set-clear-native!
|
|
display
|
|
display-native
|
|
set-display!
|
|
set-display-native!
|
|
visibility
|
|
visibility-native
|
|
set-visibility!
|
|
set-visibility-native!
|
|
list-style-type
|
|
list-style-type-native
|
|
set-list-style-type!
|
|
set-list-style-type-native!
|
|
list-style-position
|
|
list-style-position-native
|
|
set-list-style-position!
|
|
set-list-style-position-native!
|
|
list-style-image
|
|
list-style-image-native
|
|
set-list-style-image!
|
|
set-list-style-image-native!
|
|
list-style
|
|
list-style-native
|
|
set-list-style!
|
|
set-list-style-native!
|
|
position
|
|
position-native
|
|
overflow
|
|
overflow-native
|
|
set-overflow!
|
|
set-overflow-native!
|
|
pagebreak-before
|
|
pagebreak-before-native
|
|
set-pagebreak-before!
|
|
set-pagebreak-before-native!
|
|
pagebreak-after
|
|
pagebreak-after-native
|
|
set-pagebreak-after!
|
|
css-text-native
|
|
set-css-text-native!
|
|
cursor
|
|
cursor-native
|
|
set-cursor!
|
|
set-cursor-native!
|
|
clip
|
|
clip-native
|
|
set-clip!
|
|
set-clip-native!
|
|
filter
|
|
filter-native
|
|
set-filter!
|
|
set-filter-native!
|
|
style-string
|
|
text-decoration-none
|
|
set-text-decoration-none!
|
|
text-decoration-underline
|
|
set-text-decoration-underline!
|
|
text-decoration-overline
|
|
set-text-decoration-overline!
|
|
text-decoration-linethrough
|
|
set-text-decoration-linethrough!
|
|
text-decoration-blink
|
|
set-text-decoration-blink!
|
|
pixel-top
|
|
set-pixel-top!
|
|
pixel-left
|
|
set-pixel-left!
|
|
pixel-width
|
|
set-pixel-width!
|
|
pixel-height
|
|
set-pixel-height!
|
|
pos-top
|
|
set-pos-top!
|
|
pos-left
|
|
set-pos-left!
|
|
pos-width
|
|
set-pos-width!
|
|
pos-height
|
|
set-pos-height!
|
|
font-size
|
|
font-size-native
|
|
set-font-size!
|
|
set-font-size-native!
|
|
color
|
|
color-native
|
|
set-color!
|
|
set-color-native!
|
|
background-color
|
|
background-color-native
|
|
set-background-color!
|
|
set-background-color-native!
|
|
background-position-x
|
|
background-position-x-native
|
|
set-background-position-x!
|
|
set-background-position-x-native!
|
|
background-position-y
|
|
background-position-y-native
|
|
set-background-position-y!
|
|
set-background-position-y-native!
|
|
letter-spacing
|
|
letter-spacing-native
|
|
set-letter-spacing!
|
|
set-letter-spacing-native!
|
|
vertical-align
|
|
vertical-align-native
|
|
set-vertical-align!
|
|
set-vertical-align-native!
|
|
text-indent
|
|
text-indent-native
|
|
set-text-indent!
|
|
set-text-indent-native!
|
|
line-height
|
|
line-height-native
|
|
set-line-height!
|
|
set-line-height-native!
|
|
margin-top
|
|
margin-top-native
|
|
set-margin-top!
|
|
set-margin-top-native!
|
|
margin-bottom
|
|
margin-bottom-native
|
|
set-margin-bottom!
|
|
set-margin-bottom-native!
|
|
margin-left
|
|
margin-left-native
|
|
set-margin-left!
|
|
set-margin-left-native!
|
|
margin-right
|
|
margin-right-native
|
|
set-margin-right!
|
|
set-margin-right-native!
|
|
padding-top
|
|
padding-top-native
|
|
set-padding-top!
|
|
set-padding-top-native!
|
|
padding-bottom
|
|
padding-bottom-native
|
|
set-padding-bottom!
|
|
set-padding-bottom-native!
|
|
padding-left
|
|
padding-left-native
|
|
set-padding-left!
|
|
set-padding-left-native!
|
|
padding-right
|
|
padding-right-native
|
|
set-padding-right!
|
|
set-padding-right-native!
|
|
width
|
|
width-native
|
|
set-width!
|
|
set-width-native!
|
|
height
|
|
height-native
|
|
set-height!
|
|
set-height-native!
|
|
top
|
|
top-native
|
|
set-top!
|
|
set-top-native!
|
|
left
|
|
left-native
|
|
set-left!
|
|
set-left-native!
|
|
z-index
|
|
z-index-native
|
|
set-z-index!
|
|
set-z-index-native!)
|
|
|
|
; private fields
|
|
(define elt dhtml-element)
|
|
|
|
(define doc document)
|
|
|
|
(define get-string-as-symbol
|
|
(lambda (f name)
|
|
(let ([s (f elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error name)
|
|
(string->symbol s)))))
|
|
|
|
(define set-symbol-as-string
|
|
(lambda (sym vals f name)
|
|
(unless (member sym vals)
|
|
(error
|
|
(format "~a: Expected value in '~a, got ~a"
|
|
name vals sym)))
|
|
(f elt (symbol->string sym))))
|
|
|
|
(define html-insertion-maker
|
|
(lambda (f)
|
|
(lambda (s)
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda () (f elt s))
|
|
html-post))))
|
|
|
|
(define insert-object-maker
|
|
(lambda (name->html)
|
|
(opt-lambda
|
|
(object width height [size 'pixels])
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda ()
|
|
(let ([old-objects (mxprims:document-objects doc)])
|
|
(mxprims:element-insert-html
|
|
elt
|
|
(name->html object width height size))
|
|
(let* ([new-objects (mxprims:document-objects doc)]
|
|
[obj (car (mzlib:remove* old-objects new-objects
|
|
com-object-eq?))])
|
|
(mxprims:com-register-object obj)
|
|
obj)))
|
|
html-post))))
|
|
|
|
(define append-object-maker
|
|
(lambda (name->html)
|
|
(opt-lambda
|
|
(object width height [size 'pixels])
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda ()
|
|
(let* ([old-objects (mxprims:document-objects doc)])
|
|
(mxprims:element-append-html
|
|
elt
|
|
(name->html object width height size))
|
|
(let* ([new-objects (mxprims:document-objects doc)]
|
|
[obj (car (mzlib:remove* old-objects
|
|
new-objects
|
|
com-object-eq?))])
|
|
(mxprims:com-register-object obj)
|
|
obj)))
|
|
html-post))))
|
|
|
|
(define insert-object-from-coclass-raw
|
|
(insert-object-maker coclass->html))
|
|
(define append-object-from-coclass-raw
|
|
(append-object-maker coclass->html))
|
|
(define insert-object-from-progid-raw
|
|
(insert-object-maker progid->html))
|
|
(define append-object-from-progid-raw
|
|
(append-object-maker progid->html))
|
|
(define insert-html
|
|
(lambda (s)
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda () (mxprims:element-insert-html elt s))
|
|
html-post)))
|
|
(define get-html
|
|
(lambda () (mxprims:element-get-html elt)))
|
|
(define get-text
|
|
(lambda () (mxprims:element-get-text elt)))
|
|
(define insert-text
|
|
(lambda (s)
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda () (mxprims:element-insert-text elt s))
|
|
html-post)))
|
|
(define append-text
|
|
(lambda (s)
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda () (mxprims:element-append-text elt s))
|
|
html-post)))
|
|
(define append-html
|
|
(lambda (s)
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda () (mxprims:element-append-html elt s))
|
|
html-post)))
|
|
(define replace-html
|
|
(lambda (s)
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda () (mxprims:element-replace-html elt s))
|
|
html-post)))
|
|
(define insert-object-from-coclass
|
|
(lambda args
|
|
(apply insert-object-from-coclass-raw args)))
|
|
(define append-object-from-coclass
|
|
(lambda args
|
|
(apply append-object-from-coclass-raw args)))
|
|
(define insert-object-from-progid
|
|
(lambda args
|
|
(apply insert-object-from-progid-raw args)))
|
|
(define append-object-from-progid
|
|
(lambda args
|
|
(apply append-object-from-progid-raw args)))
|
|
(define focus
|
|
(lambda ()
|
|
(mxprims:element-focus elt)))
|
|
(define selection
|
|
(lambda ()
|
|
(mxprims:element-selection elt)))
|
|
(define set-selection!
|
|
(lambda (val)
|
|
(mxprims:element-set-selection! elt val)))
|
|
(define attribute
|
|
(lambda (s)
|
|
(mxprims:element-attribute elt s)))
|
|
(define set-attribute!
|
|
(lambda (a v)
|
|
(mxprims:element-set-attribute! elt a v)))
|
|
(define click
|
|
(lambda ()
|
|
(mxprims:element-click elt)))
|
|
(define tag
|
|
(lambda ()
|
|
(mxprims:element-tag elt)))
|
|
(define font-family
|
|
(lambda ()
|
|
(let ([s (mxprims:element-font-family elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error "font-family")
|
|
(style:string->font-families s)))))
|
|
(define font-family-native
|
|
(lambda ()
|
|
(mxprims:element-font-family elt)))
|
|
(define set-font-family!
|
|
(lambda (ff)
|
|
(unless (and (pair? ff)
|
|
(andmap string? ff))
|
|
(error "set-font-family!: Expected list of strings, got"
|
|
ff))
|
|
(mxprims:element-set-font-family!
|
|
elt
|
|
(style:font-families->string ff))))
|
|
(define set-font-family-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-font-family! elt s)))
|
|
(define font-style
|
|
(lambda ()
|
|
(get-string-as-symbol
|
|
mxprims:element-font-style "font-style")))
|
|
(define font-style-native
|
|
(lambda ()
|
|
(mxprims:element-font-style elt)))
|
|
(define set-font-style!
|
|
(lambda (sym)
|
|
(set-symbol-as-string sym *font-styles*
|
|
mxprims:element-set-font-style!
|
|
"set-font-style!")))
|
|
(define set-font-style-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-font-style! elt s)))
|
|
(define font-variant
|
|
(lambda ()
|
|
(get-string-as-symbol mxprims:element-font-variant
|
|
"font-variant")))
|
|
(define font-variant-native
|
|
(lambda ()
|
|
(mxprims:element-font-variant elt)))
|
|
(define set-font-variant!
|
|
(lambda (sym)
|
|
(set-symbol-as-string
|
|
sym *font-variants* mxprims:element-set-font-variant!
|
|
"set-font-variant!")))
|
|
(define set-font-variant-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-font-variant! elt s)))
|
|
(define font-weight
|
|
(lambda ()
|
|
(let ([s (mxprims:element-font-weight elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error "font-weight")
|
|
(let ((c (string-ref s 0)))
|
|
(if (char-numeric? c)
|
|
(string->number s)
|
|
(string->symbol s)))))))
|
|
(define font-weight-native
|
|
(lambda ()
|
|
(mxprims:element-font-weight elt)))
|
|
(define set-font-weight!
|
|
(lambda (w)
|
|
(unless (member w
|
|
'(bold bolder lighter normal
|
|
100 200 300 400 500 600 700 800 900))
|
|
(error
|
|
(string-append
|
|
"Expected value in "
|
|
"'(bold bolder lighter normal "
|
|
"100 200 300 400 500 600 700 800 900),"
|
|
"got ~a")
|
|
w))
|
|
(let ((s (if (number? w)
|
|
(number->string w)
|
|
(symbol->string w))))
|
|
(mxprims:element-set-font-weight! elt s))))
|
|
|
|
|
|
(define set-font-weight-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-font-weight! elt s)))
|
|
(define font-native
|
|
(lambda ()
|
|
(mxprims:element-font elt)))
|
|
(define set-font-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-font! elt s)))
|
|
(define background-native
|
|
(lambda ()
|
|
(mxprims:element-background elt)))
|
|
(define set-background-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-background! elt s)))
|
|
(define background-attachment
|
|
(lambda ()
|
|
(get-string-as-symbol mxprims:element-background-attachment
|
|
"background-attachment")))
|
|
(define background-attachment-native
|
|
(lambda ()
|
|
(mxprims:element-background-attachment elt)))
|
|
(define set-background-attachment!
|
|
(lambda (sym)
|
|
(set-symbol-as-string
|
|
sym *background-attachments*
|
|
mxprims:element-set-background-attachment!
|
|
"set-background-attachment!")))
|
|
(define set-background-attachment-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-background-attachment! elt s)))
|
|
(define background-image
|
|
(lambda ()
|
|
(let ([s (mxprims:element-background-image elt)])
|
|
(cond
|
|
[(empty-string? s)
|
|
(empty-property-error "background-image")]
|
|
[(string=? s "none") 'none]
|
|
[(string-ci=? (substring s 0 3) "url")
|
|
(list->string
|
|
(mzlib:filter (lambda (c)
|
|
(not (member c '(#\( #\)))))
|
|
(string->list
|
|
(substring s 3 (string-length s)))))]
|
|
[else (error "Unknown background-image value: ~a"
|
|
s)]))))
|
|
(define background-image-native
|
|
(lambda ()
|
|
(mxprims:element-background-image elt)))
|
|
(define set-background-image!
|
|
(lambda (image)
|
|
(cond
|
|
[(eq? image 'none)
|
|
(mxprims:element-set-background-image! elt "none")]
|
|
[(string? image)
|
|
(mxprims:element-set-background-image!
|
|
elt
|
|
(string-append "url(" image ")"))]
|
|
[else
|
|
(error "Expected 'none or string, got: ~a" image)])))
|
|
(define set-background-image-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-background-image! elt s)))
|
|
(define background-repeat
|
|
(lambda ()
|
|
(get-string-as-symbol mxprims:element-background-repeat
|
|
"background-repeat")))
|
|
(define background-repeat-native
|
|
(lambda ()
|
|
(mxprims:element-background-repeat elt)))
|
|
(define set-background-repeat!
|
|
(lambda (sym)
|
|
(set-symbol-as-string
|
|
sym *background-repeats*
|
|
mxprims:element-set-background-repeat!
|
|
"set-background-repeat!")))
|
|
(define set-background-repeat-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-background-repeat! elt s)))
|
|
(define background-position
|
|
(lambda ()
|
|
(let ([s (mxprims:element-background-position elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error "background-position")
|
|
(style:string->background-position s)))))
|
|
(define background-position-native
|
|
(lambda ()
|
|
(mxprims:element-background-position elt)))
|
|
(define set-background-position!
|
|
(lambda (pos)
|
|
(cond
|
|
[(and (pair? pos) (= (length pos) 2))
|
|
(if (andmap symbol? pos)
|
|
(let ([elt-1 (car pos)]
|
|
[elt-2 (cadr pos)])
|
|
(if (or (and (horizontal? elt-1)
|
|
(vertical? elt-2))
|
|
(and (vertical? elt-1)
|
|
(horizontal? elt-2)))
|
|
(mxprims:element-set-background-position!
|
|
elt
|
|
(string-append (symbol->string elt-1)
|
|
" "
|
|
(symbol->string elt-2)))
|
|
(error
|
|
(format
|
|
(string-append
|
|
"One symbol must be from "
|
|
"'~a, other from "
|
|
"'~a, got: ~a")
|
|
*horizontals* *verticals* pos))))
|
|
(if (andmap style:percentage-or-length? pos)
|
|
(mxprims:element-set-background-position!
|
|
elt
|
|
(string-append
|
|
(style:percentage-or-length->string (car pos))
|
|
" "
|
|
(style:percentage-or-length->string (cadr pos))))
|
|
(error
|
|
(format
|
|
(string-append
|
|
"Two elements of list "
|
|
" must be either a percentage or "
|
|
" CSS length, got: ~a") pos))))]
|
|
[(style:percentage-or-length? pos)
|
|
(mxprims:element-set-background-position!
|
|
elt
|
|
(style:percentage-or-length->string pos))]
|
|
[else
|
|
(error
|
|
(format
|
|
(string-append
|
|
"Expected any of "
|
|
"1) a list of two symbols, one "
|
|
"from '~a, the other from '~a, or "
|
|
"2) a two element list, where each element is a "
|
|
"percentage or CSS length, or "
|
|
"3) a percentage, or "
|
|
"4) a CSS length. Got: ~a")
|
|
*horizontals* *verticals* pos))])))
|
|
(define set-background-position-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-background-position! elt s)))
|
|
(define text-decoration
|
|
(lambda ()
|
|
(style:validated-string->symbols
|
|
(mxprims:element-text-decoration elt)
|
|
"text-decoration" style:parse-decoration)))
|
|
(define text-decoration-native
|
|
(lambda ()
|
|
(mxprims:element-text-decoration elt)))
|
|
(define set-text-decoration!
|
|
(lambda (decs)
|
|
(unless
|
|
(andmap decoration? decs)
|
|
(error
|
|
(format "Expected text decorations from ~a, got: ~a"
|
|
*decorations* decs)))
|
|
(mxprims:element-set-text-decoration! elt
|
|
(symbols->string decs))))
|
|
(define set-text-decoration-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-text-decoration! elt s)))
|
|
(define text-transform
|
|
(lambda ()
|
|
(get-string-as-symbol mxprims:element-text-transform
|
|
"text-transform")))
|
|
(define text-transform-native
|
|
(lambda ()
|
|
(mxprims:element-text-transform elt)))
|
|
(define set-text-transform!
|
|
(lambda (sym)
|
|
(set-symbol-as-string
|
|
sym *text-transforms* mxprims:element-set-text-transform!
|
|
"set-text-transforms!")))
|
|
(define set-text-transform-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-text-transform! elt s)))
|
|
(define text-align
|
|
(lambda ()
|
|
(get-string-as-symbol
|
|
mxprims:element-text-align
|
|
"text-align")))
|
|
(define text-align-native
|
|
(lambda ()
|
|
(mxprims:element-text-align elt)))
|
|
(define set-text-align!
|
|
(lambda (sym)
|
|
(set-symbol-as-string
|
|
sym *text-aligns*
|
|
mxprims:element-set-text-align!
|
|
"set-text-align!")))
|
|
(define set-text-align-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-text-align! elt s)))
|
|
(define margin
|
|
(lambda ()
|
|
(let ([s (mxprims:element-margin elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error "margin")
|
|
(style:string->margin s)))))
|
|
(define margin-native
|
|
(lambda ()
|
|
(mxprims:element-margin elt)))
|
|
(define set-margin!
|
|
(lambda (lst)
|
|
(let ([len (length lst)])
|
|
(when (or (< len 1) (> len 4))
|
|
(error
|
|
"Expected one to four margin values, got"
|
|
lst)))
|
|
(mxprims:element-set-margin! elt (style:margin->string lst))))
|
|
(define set-margin-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-margin! elt s)))
|
|
(define padding
|
|
(lambda ()
|
|
(let ([s (mxprims:element-padding elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error "padding")
|
|
(style:string->padding s)))))
|
|
(define padding-native
|
|
(lambda ()
|
|
(mxprims:element-padding elt)))
|
|
(define set-padding!
|
|
(lambda (pads)
|
|
(unless (and (pair? pads)
|
|
(let ([len (length pads)])
|
|
(and (>= len 1) (<= len 4)))
|
|
(andmap style:percentage-or-length? pads))
|
|
(error (string-append
|
|
"set-padding: expected list of "
|
|
"1 to 4 css-percentages or "
|
|
"css-lengths, got") pads))
|
|
(mxprims:element-set-padding!
|
|
elt
|
|
(style:padding->string pads))))
|
|
(define set-padding-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-padding! elt s)))
|
|
(define border-raw
|
|
(style:make-border-getter elt mxprims:element-border "border"))
|
|
(define border
|
|
(lambda args
|
|
(apply border-raw args)))
|
|
(define border-native
|
|
(lambda (s)
|
|
(mxprims:element-border elt s)))
|
|
(define set-border!
|
|
(lambda (cs)
|
|
(style:set-border-with-fun
|
|
elt cs mxprims:element-set-border!)))
|
|
(define set-border-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border! elt s)))
|
|
(define border-top-raw
|
|
(style:make-border-getter
|
|
elt mxprims:element-border-top "border-top"))
|
|
(define border-top
|
|
(lambda args
|
|
(apply border-top-raw args)))
|
|
(define border-top-native
|
|
(lambda ()
|
|
(mxprims:element-border-top elt)))
|
|
(define set-border-top!
|
|
(lambda (cs)
|
|
(style:set-border-with-fun
|
|
elt cs mxprims:element-set-border-top!)))
|
|
(define set-border-top-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-top! elt s)))
|
|
(define border-bottom-raw
|
|
(style:make-border-getter
|
|
elt mxprims:element-border-bottom "border-bottom"))
|
|
(define border-bottom
|
|
(lambda args
|
|
(apply border-bottom-raw args)))
|
|
(define border-bottom-native
|
|
(lambda ()
|
|
(mxprims:element-border-bottom elt)))
|
|
(define set-border-bottom!
|
|
(lambda (cs)
|
|
(style:set-border-with-fun
|
|
elt cs mxprims:element-set-border-bottom!)))
|
|
(define set-border-bottom-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-bottom! elt s)))
|
|
(define border-left-raw
|
|
(style:make-border-getter
|
|
elt mxprims:element-border-left "border-left"))
|
|
(define border-left
|
|
(lambda args
|
|
(apply border-left-raw args)))
|
|
(define border-left-native
|
|
(lambda ()
|
|
(mxprims:element-border-left elt)))
|
|
(define set-border-left!
|
|
(lambda (cs)
|
|
(style:set-border-with-fun
|
|
elt cs mxprims:element-set-border-left!)))
|
|
(define set-border-left-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-left! elt s)))
|
|
(define border-right-raw
|
|
(style:make-border-getter
|
|
elt mxprims:element-border-right "border-right"))
|
|
(define border-right
|
|
(lambda args
|
|
(apply border-right-raw args)))
|
|
(define border-right-native
|
|
(lambda ()
|
|
(mxprims:element-border-right elt)))
|
|
(define set-border-right!
|
|
(lambda (cs)
|
|
(style:set-border-with-fun
|
|
elt cs mxprims:element-set-border-right!)))
|
|
(define set-border-right-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-right! elt s)))
|
|
(define border-color-raw
|
|
(style:make-color-getter
|
|
elt
|
|
mxprims:element-border-color
|
|
"border-color"))
|
|
(define border-color
|
|
(lambda args
|
|
(apply border-color-raw args)))
|
|
(define border-color-native
|
|
(lambda ()
|
|
(mxprims:element-border-color elt)))
|
|
(define set-border-color-raw!
|
|
(style:make-color-setter
|
|
elt mxprims:element-set-border-color!
|
|
"set-border-color!"))
|
|
(define set-border-color!
|
|
(lambda args
|
|
(apply set-border-color-raw! args)))
|
|
(define set-border-color-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-color! elt s)))
|
|
(define border-width-raw
|
|
(style:make-border-width-getter
|
|
elt mxprims:element-border-width "border-width"))
|
|
(define border-width
|
|
(lambda args
|
|
(apply border-width-raw args)))
|
|
(define border-width-native
|
|
(lambda ()
|
|
(mxprims:element-border-width elt)))
|
|
(define set-border-width!
|
|
(lambda (s)
|
|
(unless (style:border-width? s)
|
|
(error
|
|
(format "border-width: Expected element of ~a or CSS length, got: ~a"
|
|
*border-widths* s)))
|
|
(mxprims:element-set-border-width!
|
|
elt
|
|
(style:border-width->string s))))
|
|
(define set-border-width-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-width! elt s)))
|
|
(define border-style-raw
|
|
(style:make-border-style-getter
|
|
elt mxprims:element-border-style
|
|
"border-style"))
|
|
(define border-style
|
|
(lambda args
|
|
(apply border-style-raw args)))
|
|
(define border-style-native
|
|
(lambda ()
|
|
(mxprims:element-border-style elt)))
|
|
(define set-border-style-raw!
|
|
(style:make-border-style-setter
|
|
elt mxprims:element-set-border-style!
|
|
"set-border-style!"))
|
|
(define set-border-style!
|
|
(lambda args
|
|
(apply set-border-style-raw! args)))
|
|
(define set-border-style-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-style! elt s)))
|
|
(define border-top-style-raw
|
|
(style:make-border-style-getter
|
|
elt mxprims:element-border-top-style
|
|
"border-top-style"))
|
|
(define border-top-style
|
|
(lambda args
|
|
(apply border-top-style-raw args)))
|
|
(define border-top-style-native
|
|
(lambda ()
|
|
(mxprims:element-border-top-style elt)))
|
|
(define set-border-top-style-raw!
|
|
(style:make-border-style-setter
|
|
elt mxprims:element-set-border-top-style!
|
|
"set-border-top-style!"))
|
|
(define set-border-top-style!
|
|
(lambda args
|
|
(apply set-border-top-style-raw! args)))
|
|
(define set-border-top-style-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-top-style! elt s)))
|
|
(define border-bottom-style-raw
|
|
(style:make-border-style-getter
|
|
elt mxprims:element-border-bottom-style
|
|
"border-bottom-style"))
|
|
(define border-bottom-style
|
|
(lambda args
|
|
(apply border-bottom-style-raw args)))
|
|
(define border-bottom-style-native
|
|
(lambda ()
|
|
(mxprims:element-border-bottom-style elt)))
|
|
(define set-border-bottom-style-raw!
|
|
(style:make-border-style-setter
|
|
elt mxprims:element-set-border-bottom-style!
|
|
"set-border-bottom-style!"))
|
|
(define set-border-bottom-style!
|
|
(lambda args
|
|
(apply set-border-bottom-style-raw! args)))
|
|
(define set-border-bottom-style-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-bottom-style! elt s)))
|
|
(define border-left-style-raw
|
|
(style:make-border-style-getter
|
|
elt mxprims:element-border-left-style
|
|
"border-left-style"))
|
|
(define border-left-style
|
|
(lambda args
|
|
(apply border-left-style-raw args)))
|
|
(define border-left-style-native
|
|
(lambda ()
|
|
(mxprims:element-border-left-style elt)))
|
|
(define set-border-left-style-raw!
|
|
(style:make-border-style-setter
|
|
elt mxprims:element-set-border-left-style!
|
|
"set-border-left-style!"))
|
|
(define set-border-left-style!
|
|
(lambda args
|
|
(apply set-border-left-style-raw! args)))
|
|
(define set-border-left-style-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-left-style! elt s)))
|
|
(define border-right-style-raw
|
|
(style:make-border-style-getter
|
|
elt mxprims:element-border-right-style
|
|
"border-right-style"))
|
|
(define border-right-style
|
|
(lambda args
|
|
(apply border-right-style-raw args)))
|
|
(define border-right-style-native
|
|
(lambda ()
|
|
(mxprims:element-border-right-style elt)))
|
|
(define set-border-right-style-raw!
|
|
(style:make-border-style-setter elt
|
|
mxprims:element-set-border-right-style!
|
|
"set-border-right-style!"))
|
|
(define set-border-right-style!
|
|
(lambda args
|
|
(apply set-border-right-style-raw! args)))
|
|
(define set-border-right-style-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-right-style! elt s)))
|
|
(define border-top-color-raw
|
|
(style:make-color-getter
|
|
elt mxprims:element-border-top-color
|
|
"border-top-color"))
|
|
(define border-top-color
|
|
(lambda args
|
|
(apply border-top-color-raw args)))
|
|
(define border-top-color-native!
|
|
(lambda ()
|
|
(mxprims:element-border-top-color elt)))
|
|
(define set-border-top-color-raw!
|
|
(style:make-color-setter
|
|
elt mxprims:element-set-border-top-color!
|
|
"set-border-top-color!"))
|
|
(define set-border-top-color!
|
|
(lambda args
|
|
(apply set-border-top-color-raw! args)))
|
|
(define set-border-top-color-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-top-color! elt s)))
|
|
(define border-bottom-color-raw
|
|
(style:make-color-getter
|
|
elt mxprims:element-border-bottom-color
|
|
"border-bottom-color"))
|
|
(define border-bottom-color
|
|
(lambda args
|
|
(apply border-bottom-color-raw args)))
|
|
(define border-bottom-color-native
|
|
(lambda ()
|
|
(mxprims:element-border-bottom-color elt)))
|
|
(define set-border-bottom-color-raw!
|
|
(style:make-color-setter
|
|
elt mxprims:element-set-border-bottom-color!
|
|
"set-border-bottom-color!"))
|
|
(define set-border-bottom-color!
|
|
(lambda args
|
|
(apply set-border-bottom-color-raw! args)))
|
|
(define set-border-bottom-color-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-bottom-color! elt s)))
|
|
(define border-left-color-raw
|
|
(style:make-color-getter
|
|
elt mxprims:element-border-left-color
|
|
"border-left-color"))
|
|
(define border-left-color
|
|
(lambda args
|
|
(apply border-left-color-raw args)))
|
|
(define border-left-color-native
|
|
(lambda ()
|
|
(mxprims:element-border-left-color elt)))
|
|
(define set-border-left-color-raw!
|
|
(style:make-color-setter
|
|
elt mxprims:element-set-border-left-color!
|
|
"set-border-left-color!"))
|
|
(define set-border-left-color!
|
|
(lambda args
|
|
(apply set-border-left-color-raw! args)))
|
|
(define set-border-left-color-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-left-color! elt s)))
|
|
(define border-right-color-raw
|
|
(style:make-color-getter
|
|
elt mxprims:element-border-right-color
|
|
"border-right-color"))
|
|
(define border-right-color
|
|
(lambda args
|
|
(apply border-right-color-raw args)))
|
|
(define border-right-color-native
|
|
(lambda ()
|
|
(mxprims:element-border-right-color elt)))
|
|
(define set-border-right-color-raw!
|
|
(style:make-color-setter
|
|
elt mxprims:element-set-border-right-color!
|
|
"set-border-right-color!"))
|
|
(define set-border-right-color!
|
|
(lambda args
|
|
(apply set-border-right-color-raw! args)))
|
|
(define set-border-right-color-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-right-color! elt s)))
|
|
(define border-top-width-raw
|
|
(style:make-border-width-getter
|
|
elt mxprims:element-border-top-width "border-top-width"))
|
|
(define border-top-width
|
|
(lambda args
|
|
(apply border-top-width-raw args)))
|
|
(define border-top-width-native
|
|
(lambda ()
|
|
(mxprims:element-border-top-width elt)))
|
|
(define set-border-top-width-raw!
|
|
(style:make-border-width-setter
|
|
elt mxprims:element-set-border-top-width!
|
|
"set-border-top-width!"))
|
|
(define set-border-top-width!
|
|
(lambda args
|
|
(apply set-border-top-width-raw! args)))
|
|
(define set-border-top-width-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-top-width! elt s)))
|
|
(define border-bottom-width-raw
|
|
(style:make-border-width-getter
|
|
elt mxprims:element-border-bottom-width "border-bottom-width"))
|
|
(define border-bottom-width
|
|
(lambda args
|
|
(apply border-bottom-width-raw args)))
|
|
(define border-bottom-width-native
|
|
(lambda ()
|
|
(mxprims:element-border-bottom-width elt)))
|
|
(define set-border-bottom-width-raw!
|
|
(style:make-border-width-setter
|
|
elt mxprims:element-set-border-bottom-width!
|
|
"set-border-bottom-width!"))
|
|
(define set-border-bottom-width!
|
|
(lambda args
|
|
(apply set-border-bottom-width-raw! args)))
|
|
(define set-border-bottom-width-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-bottom-width! elt s)))
|
|
(define border-left-width-raw
|
|
(style:make-border-width-getter
|
|
elt mxprims:element-border-left-width "border-left-width"))
|
|
(define border-left-width
|
|
(lambda args
|
|
(apply border-left-width-raw args)))
|
|
(define border-left-width-native
|
|
(lambda ()
|
|
(mxprims:element-border-left-width elt)))
|
|
(define set-border-left-width-raw!
|
|
(style:make-border-width-setter
|
|
elt mxprims:element-set-border-left-width!
|
|
"set-border-left-width!"))
|
|
(define set-border-left-width!
|
|
(lambda args
|
|
(apply set-border-left-width-raw! args)))
|
|
(define set-border-left-width-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-left-width! elt s)))
|
|
(define border-right-width-raw
|
|
(style:make-border-width-getter
|
|
elt mxprims:element-border-right-width "border-right-width"))
|
|
(define border-right-width
|
|
(lambda args
|
|
(apply border-right-width-raw args)))
|
|
(define border-right-width-native
|
|
(lambda ()
|
|
(mxprims:element-border-right-width elt)))
|
|
(define set-border-right-width-raw!
|
|
(style:make-border-width-setter
|
|
elt mxprims:element-set-border-right-width!
|
|
"set-border-right-width!"))
|
|
(define set-border-right-width!
|
|
(lambda args
|
|
(apply set-border-right-width-raw! args)))
|
|
(define set-border-right-width-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-border-right-width! elt s)))
|
|
(define style-float-raw
|
|
(style:make-element-getter
|
|
elt
|
|
mxprims:element-style-float "style-float" ))
|
|
(define style-float
|
|
(lambda args
|
|
(apply style-float-raw args)))
|
|
(define style-float-native
|
|
(lambda ()
|
|
(mxprims:element-style-float elt)))
|
|
(define set-style-float-raw!
|
|
(style:make-element-setter elt
|
|
style-float?
|
|
*style-floats*
|
|
mxprims:element-set-style-float!))
|
|
(define set-style-float!
|
|
(lambda args
|
|
(apply set-style-float-raw! args)))
|
|
(define set-style-float-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-style-float! elt s)))
|
|
(define clear-raw
|
|
(style:make-element-getter
|
|
elt mxprims:element-clear "clear"))
|
|
(define clear
|
|
(lambda args
|
|
(apply clear-raw args)))
|
|
(define clear-native
|
|
(lambda ()
|
|
(mxprims:element-clear elt)))
|
|
(define set-clear-raw!
|
|
(style:make-element-setter elt
|
|
clear?
|
|
*clears*
|
|
mxprims:element-set-clear!))
|
|
(define set-clear!
|
|
(lambda args
|
|
(apply set-clear-raw! args)))
|
|
(define set-clear-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-clear! elt s)))
|
|
(define display-raw
|
|
(style:make-element-getter
|
|
elt mxprims:element-display "display"))
|
|
(define display
|
|
(lambda args
|
|
(apply display-raw args)))
|
|
(define display-native
|
|
(lambda ()
|
|
(mxprims:element-display elt)))
|
|
(define set-display-raw!
|
|
(style:make-element-setter elt
|
|
display?
|
|
*displays*
|
|
mxprims:element-set-display!))
|
|
(define set-display!
|
|
(lambda args
|
|
(apply set-display-raw! args)))
|
|
(define set-display-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-display! elt s)))
|
|
(define visibility-raw
|
|
(style:make-element-getter
|
|
elt mxprims:element-visibility
|
|
"visibility"))
|
|
(define visibility
|
|
(lambda args
|
|
(apply visibility-raw args)))
|
|
(define visibility-native
|
|
(lambda ()
|
|
(mxprims:element-visibility elt)))
|
|
(define set-visibility-raw!
|
|
(style:make-element-setter elt
|
|
visibility?
|
|
*visibilities*
|
|
mxprims:element-set-visibility!))
|
|
(define set-visibility!
|
|
(lambda args
|
|
(apply set-visibility-raw! args)))
|
|
(define set-visibility-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-visibility! elt s)))
|
|
(define list-style-type-raw
|
|
(style:make-element-getter
|
|
elt mxprims:element-list-style-type
|
|
"list-style-type"))
|
|
(define list-style-type
|
|
(lambda args
|
|
(apply list-style-type-raw args)))
|
|
(define list-style-type-native
|
|
(lambda ()
|
|
(mxprims:element-list-style-type elt)))
|
|
(define set-list-style-type-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-list-style-type! elt s)))
|
|
(define list-style-position-raw
|
|
(style:make-element-getter
|
|
elt mxprims:element-list-style-position
|
|
"list-style-position"))
|
|
(define list-style-position
|
|
(lambda args
|
|
(apply list-style-position-raw args)))
|
|
(define list-style-position-native
|
|
(lambda ()
|
|
(mxprims:element-list-style-position elt)))
|
|
(define set-list-style-position-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-list-style-position! elt s)))
|
|
(define list-style-image
|
|
(lambda ()
|
|
(let ([s (mxprims:element-list-style-image elt)])
|
|
(when (empty-string? s)
|
|
(empty-property-error "list-style-image"))
|
|
(cond
|
|
[(string-ci=? s "none") 'none]
|
|
[(string-ci=? (substring s 0 4) "url(")
|
|
(style:url->string s)]
|
|
[else
|
|
(error
|
|
(format
|
|
"list-style-image: Expected 'none or URL, got: ~a" s))]))))
|
|
(define list-style-image-native
|
|
(lambda ()
|
|
(mxprims:element-list-style-image elt)))
|
|
(define set-list-style-image!
|
|
(lambda (s)
|
|
(let ([str (if (eq? s 'none)
|
|
"none"
|
|
(style:string->url s))])
|
|
(mxprims:element-set-list-style-image! elt str))))
|
|
(define set-list-style-image-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-list-style-image! elt s)))
|
|
(define list-style
|
|
(lambda ()
|
|
(let* ([s (mxprims:element-list-style elt)]
|
|
[elts (style:parse-string s)])
|
|
(map style:string->list-style-item elts))))
|
|
(define list-style-native
|
|
(lambda ()
|
|
(mxprims:element-list-style elt)))
|
|
(define set-list-style!
|
|
(lambda (items)
|
|
(mxprims:element-set-list-style!
|
|
elt
|
|
(fold-strings-with-spaces
|
|
(map style:list-style-item->string items)))))
|
|
(define set-list-style-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-list-style! elt s)))
|
|
(define position-raw
|
|
(style:make-element-getter
|
|
elt mxprims:element-position
|
|
"position"))
|
|
(define position
|
|
(lambda args
|
|
(apply position-raw args)))
|
|
(define position-native
|
|
(lambda ()
|
|
(mxprims:element-position elt)))
|
|
(define overflow-raw
|
|
(style:make-element-getter
|
|
elt mxprims:element-overflow "overflow"))
|
|
(define overflow
|
|
(lambda args
|
|
(apply overflow-raw args)))
|
|
(define overflow-native
|
|
(lambda ()
|
|
(mxprims:element-overflow elt)))
|
|
(define set-overflow-raw!
|
|
(style:make-element-setter elt
|
|
overflow?
|
|
*overflows*
|
|
mxprims:element-set-overflow!))
|
|
(define set-overflow!
|
|
(lambda args
|
|
(apply set-overflow-raw! args)))
|
|
(define set-overflow-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-overflow! elt s)))
|
|
(define pagebreak-before-raw
|
|
(style:make-pagebreak-getter
|
|
elt
|
|
mxprims:element-pagebreak-before))
|
|
(define pagebreak-before
|
|
(lambda args
|
|
(apply pagebreak-before-raw args)))
|
|
(define pagebreak-before-native
|
|
(lambda ()
|
|
(mxprims:element-pagebreak-before elt)))
|
|
(define set-pagebreak-before-raw!
|
|
(style:make-pagebreak-setter elt
|
|
mxprims:element-set-pagebreak-before!
|
|
"set-pagebreak-before!"))
|
|
(define set-pagebreak-before!
|
|
(lambda args
|
|
(apply set-pagebreak-before-raw! args)))
|
|
(define set-pagebreak-before-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-pagebreak-before! elt s)))
|
|
(define pagebreak-after-raw
|
|
(style:make-pagebreak-getter
|
|
elt mxprims:element-pagebreak-after))
|
|
(define pagebreak-after
|
|
(lambda args
|
|
(apply pagebreak-after-raw args)))
|
|
(define pagebreak-after-native
|
|
(lambda ()
|
|
(mxprims:element-pagebreak-after elt)))
|
|
(define set-pagebreak-after-raw!
|
|
(style:make-pagebreak-setter elt
|
|
mxprims:element-set-pagebreak-after!
|
|
"set-pagebreak-after!"))
|
|
(define set-pagebreak-after!
|
|
(lambda args
|
|
(apply set-pagebreak-after-raw! args)))
|
|
(define css-text-native
|
|
(lambda ()
|
|
(mxprims:element-css-text elt)))
|
|
(define set-css-text-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-css-text! elt s)))
|
|
(define cursor-raw
|
|
(style:make-element-getter
|
|
elt mxprims:element-cursor "cursor"))
|
|
(define cursor
|
|
(lambda args
|
|
(apply cursor-raw args)))
|
|
(define cursor-native
|
|
(lambda ()
|
|
(mxprims:element-cursor elt)))
|
|
(define set-cursor-raw!
|
|
(style:make-element-setter elt
|
|
cursor?
|
|
*cursors*
|
|
mxprims:element-set-cursor!))
|
|
(define set-cursor!
|
|
(lambda args
|
|
(apply set-cursor-raw! args)))
|
|
(define set-cursor-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-cursor! elt s)))
|
|
(define clip
|
|
(lambda ()
|
|
(let ([s (mxprims:element-clip elt)])
|
|
(cond
|
|
[(empty-string? s)
|
|
(empty-property-error "clip")]
|
|
[(string-ci=? s "auto")
|
|
'auto]
|
|
[(style:clip-rect? s)
|
|
(style:clip-rect->symbols s)]
|
|
[else
|
|
(error
|
|
(format "clip: Expected clip string, got: ~a" s))]))))
|
|
(define clip-native
|
|
(lambda ()
|
|
(mxprims:element-clip elt)))
|
|
(define set-clip!
|
|
(lambda (s)
|
|
(let ([str (cond
|
|
[(eq? s 'auto) "auto"]
|
|
[(and (pair? s)
|
|
(= (length s) 4)
|
|
(andmap
|
|
(lambda (elt)
|
|
(or (eq? elt 'auto)
|
|
(css-length? elt)))
|
|
s))
|
|
(string-append
|
|
"rect("
|
|
(fold-strings-with-spaces
|
|
(map
|
|
(lambda (elt)
|
|
(if (eq? elt 'auto)
|
|
"auto"
|
|
(style:css-length->string elt)))
|
|
s))
|
|
")")]
|
|
[else
|
|
(error
|
|
(format
|
|
(string-append
|
|
"Expected 'auto or 4-element list of "
|
|
"CSS lengths, with elements "
|
|
"possibly replaced by 'auto. Got ~a")
|
|
s))])])
|
|
(mxprims:element-set-clip! elt str))))
|
|
(define set-clip-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-clip! elt s)))
|
|
(define filter
|
|
(lambda ()
|
|
(let ([s (mxprims:element-filter elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error "filter")
|
|
(string->filter s)))))
|
|
(define filter-native
|
|
(lambda ()
|
|
(mxprims:element-filter elt)))
|
|
(define set-filter!
|
|
(lambda (flt . options)
|
|
(let ([s (filter->string flt options)])
|
|
(mxprims:element-set-filter! elt s))))
|
|
(define set-filter-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-filter! elt s)))
|
|
(define style-string
|
|
(lambda ()
|
|
(mxprims:element-style-string elt)))
|
|
; the text decoration, blink attributes are boolean
|
|
; hence no conversion to/from strings
|
|
(define text-decoration-none
|
|
(lambda ()
|
|
(mxprims:element-text-decoration-none elt)))
|
|
(define set-text-decoration-none!
|
|
(lambda (s)
|
|
(mxprims:element-set-text-decoration-none! elt s)))
|
|
(define text-decoration-underline
|
|
(lambda ()
|
|
(mxprims:element-text-decoration-underline elt)))
|
|
(define set-text-decoration-underline!
|
|
(lambda (s)
|
|
(mxprims:element-set-text-decoration-underline! elt s)))
|
|
(define text-decoration-overline
|
|
(lambda ()
|
|
(mxprims:element-text-decoration-overline elt)))
|
|
(define set-text-decoration-overline!
|
|
(lambda (s)
|
|
(mxprims:element-set-text-decoration-overline! elt s)))
|
|
(define text-decoration-linethrough
|
|
(lambda ()
|
|
(mxprims:element-text-decoration-linethrough elt)))
|
|
(define set-text-decoration-linethrough!
|
|
(lambda (s)
|
|
(mxprims:element-set-text-decoration-linethrough! elt s)))
|
|
(define text-decoration-blink
|
|
(lambda ()
|
|
(mxprims:element-text-decoration-blink elt)))
|
|
(define set-text-decoration-blink!
|
|
(lambda (s)
|
|
(mxprims:element-set-text-decoration-blink! elt s)))
|
|
; pixel attributes are all longs
|
|
; hence, no conversion to/from strings
|
|
(define pixel-top
|
|
(lambda ()
|
|
(mxprims:element-pixel-top elt)))
|
|
(define set-pixel-top!
|
|
(lambda (s)
|
|
(mxprims:element-set-pixel-top! elt s)))
|
|
(define pixel-left
|
|
(lambda ()
|
|
(mxprims:element-pixel-left elt)))
|
|
(define set-pixel-left!
|
|
(lambda (s)
|
|
(mxprims:element-set-pixel-left! elt s)))
|
|
(define pixel-width
|
|
(lambda ()
|
|
(mxprims:element-pixel-width elt)))
|
|
(define set-pixel-width!
|
|
(lambda (s)
|
|
(mxprims:element-set-pixel-width! elt s)))
|
|
(define pixel-height
|
|
(lambda ()
|
|
(mxprims:element-pixel-height elt)))
|
|
(define set-pixel-height!
|
|
(lambda (s)
|
|
(mxprims:element-set-pixel-height! elt s)))
|
|
; position attributes are all floats
|
|
; hence no conversion to/from strings
|
|
(define pos-top
|
|
(lambda ()
|
|
(mxprims:element-pos-top elt)))
|
|
(define set-pos-top!
|
|
(lambda (s)
|
|
(mxprims:element-set-pos-top! elt s)))
|
|
(define pos-left
|
|
(lambda ()
|
|
(mxprims:element-pos-left elt)))
|
|
(define set-pos-left!
|
|
(lambda (s)
|
|
(mxprims:element-set-pos-left! elt s)))
|
|
(define pos-width
|
|
(lambda ()
|
|
(mxprims:element-pos-width elt)))
|
|
(define set-pos-width!
|
|
(lambda (s)
|
|
(mxprims:element-set-pos-width! elt s)))
|
|
(define pos-height
|
|
(lambda ()
|
|
(mxprims:element-pos-height elt)))
|
|
(define set-pos-height!
|
|
(lambda (s)
|
|
(mxprims:element-set-pos-height! elt s)))
|
|
(define font-size
|
|
(lambda ()
|
|
(let ([s (mxprims:element-font-size elt)])
|
|
(if (empty-string? s)
|
|
(empty-property-error "font-size")
|
|
(style:string->font-size s)))))
|
|
(define font-size-native
|
|
(lambda ()
|
|
(mxprims:element-font-size elt)))
|
|
(define set-font-size!
|
|
(lambda (sz)
|
|
(let ([s (cond
|
|
[(font-size? sz)
|
|
(symbol->string sz)]
|
|
[(style:percentage-or-length? sz)
|
|
(style:percentage-or-length->string sz)]
|
|
[else
|
|
(error
|
|
(format (string-append
|
|
"set-font-size!: Expected element of ~a, "
|
|
"a CSS length, or CSS percentage. Got: ~a")
|
|
*font-sizes* sz))])])
|
|
(mxprims:element-set-font-size! elt s))))
|
|
(define set-font-size-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-font-size! elt s)))
|
|
(define color-raw
|
|
(style:make-color-getter elt mxprims:element-color "color"))
|
|
(define color
|
|
(lambda args
|
|
(apply color-raw args)))
|
|
(define color-native-raw
|
|
(lambda ()
|
|
(mxprims:element-color elt)))
|
|
(define color-native
|
|
(lambda args
|
|
(apply color-native-raw args)))
|
|
(define set-color-raw!
|
|
(style:make-color-setter
|
|
elt mxprims:element-set-color! "set-color!"))
|
|
(define set-color!
|
|
(lambda args
|
|
(apply set-color-raw! args)))
|
|
(define set-color-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-color! elt s)))
|
|
(define background-color-raw
|
|
(style:make-color-getter
|
|
elt mxprims:element-background-color
|
|
"background-color"))
|
|
(define background-color
|
|
(lambda args
|
|
(apply background-color-raw args)))
|
|
(define background-color-native
|
|
(lambda ()
|
|
(mxprims:element-background-color elt)))
|
|
(define set-background-color-raw!
|
|
(style:make-color-setter
|
|
elt mxprims:element-set-background-color!
|
|
"set-background-color!"))
|
|
(define set-background-color!
|
|
(lambda args
|
|
(apply set-background-color-raw! args)))
|
|
(define set-background-color-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-background-color! elt s)))
|
|
(define background-position-x-raw
|
|
(style:make-bg-pos-getter
|
|
elt
|
|
mxprims:element-background-position-x
|
|
"background-position-x"))
|
|
(define background-position-x
|
|
(lambda args
|
|
(apply background-position-x-raw args)))
|
|
(define background-position-x-native
|
|
(lambda ()
|
|
(mxprims:element-background-position-x elt)))
|
|
(define set-background-position-x-raw!
|
|
(style:make-bg-pos-setter
|
|
elt
|
|
mxprims:element-set-background-position-x!
|
|
horizontal? *horizontals*
|
|
"x"))
|
|
(define set-background-position-x!
|
|
(lambda args
|
|
(apply set-background-position-x-raw! args)))
|
|
(define set-background-position-x-native!
|
|
(lambda (n)
|
|
(mxprims:element-set-background-position-x! elt n)))
|
|
(define background-position-y-raw
|
|
(style:make-bg-pos-getter
|
|
elt
|
|
mxprims:element-background-position-y
|
|
"background-position-y"))
|
|
(define background-position-y
|
|
(lambda args
|
|
(apply background-position-y-raw args)))
|
|
(define background-position-y-native
|
|
(lambda ()
|
|
(mxprims:element-background-position-y elt)))
|
|
(define set-background-position-y-raw!
|
|
(style:make-bg-pos-setter
|
|
elt
|
|
mxprims:element-set-background-position-y!
|
|
vertical? *verticals*
|
|
"y"))
|
|
(define set-background-position-y!
|
|
(lambda args
|
|
(apply set-background-position-y-raw! args)))
|
|
(define set-background-position-y-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-background-position-y! elt s)))
|
|
(define letter-spacing-raw
|
|
(style:make-normal-or-css-getter elt
|
|
mxprims:element-letter-spacing
|
|
"letter-spacing"))
|
|
(define letter-spacing
|
|
(lambda args
|
|
(apply letter-spacing-raw args)))
|
|
(define letter-spacing-native
|
|
(lambda ()
|
|
(mxprims:element-letter-spacing elt)))
|
|
(define set-letter-spacing-raw!
|
|
(style:make-normal-or-css-setter elt
|
|
mxprims:element-set-letter-spacing!
|
|
"set-letter-spacing!"))
|
|
(define set-letter-spacing!
|
|
(lambda args
|
|
(apply set-letter-spacing-raw! args)))
|
|
(define set-letter-spacing-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-letter-spacing! elt s)))
|
|
(define vertical-align
|
|
(lambda ()
|
|
(let ([s (mxprims:element-vertical-align elt)])
|
|
(when (empty-string? s)
|
|
(empty-property-error "vertical-align"))
|
|
(string->symbol s))))
|
|
(define vertical-align-native
|
|
(lambda ()
|
|
(mxprims:element-vertical-align elt)))
|
|
(define set-vertical-align!
|
|
(lambda (sym)
|
|
(unless (vertical-align? sym)
|
|
(error
|
|
(format
|
|
(string-append "set-vertical-align!: "
|
|
"Expected element of ~a, got ~a")
|
|
*vertical-aligns* sym)))
|
|
(mxprims:element-set-vertical-align!
|
|
elt
|
|
(symbol->string sym))))
|
|
(define set-vertical-align-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-vertical-align! elt s)))
|
|
(define text-indent-raw
|
|
(style:make-css-getter elt
|
|
mxprims:element-text-indent "text-indent"))
|
|
(define text-indent
|
|
(lambda args
|
|
(apply text-indent-raw args)))
|
|
(define text-indent-native
|
|
(lambda ()
|
|
(mxprims:element-text-indent elt)))
|
|
(define set-text-indent-raw!
|
|
(style:make-css-setter elt
|
|
mxprims:element-set-text-indent!
|
|
"set-text-indent!"))
|
|
(define set-text-indent!
|
|
(lambda args
|
|
(apply set-text-indent-raw! args)))
|
|
(define set-text-indent-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-text-indent! elt s)))
|
|
(define line-height-raw
|
|
(style:make-normal-or-css-getter elt
|
|
mxprims:element-line-height
|
|
"line-height"))
|
|
(define line-height
|
|
(lambda args
|
|
(apply line-height-raw args)))
|
|
(define line-height-native
|
|
(lambda ()
|
|
(mxprims:element-line-height elt)))
|
|
(define set-line-height-raw!
|
|
(style:make-normal-or-css-setter elt
|
|
mxprims:element-set-line-height!
|
|
"set-line-height!"))
|
|
(define set-line-height!
|
|
(lambda args
|
|
(apply set-line-height-raw! args)))
|
|
(define set-line-height-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-line-height! elt s)))
|
|
(define margin-top-raw
|
|
(style:make-auto-or-css-getter elt
|
|
mxprims:element-margin-top
|
|
"margin-top"))
|
|
(define margin-top
|
|
(lambda args
|
|
(apply margin-top-raw args)))
|
|
(define margin-top-native
|
|
(lambda ()
|
|
(mxprims:element-margin-top elt)))
|
|
(define set-margin-top-raw!
|
|
(style:make-auto-or-css-setter elt
|
|
mxprims:element-set-margin-top!
|
|
"set-margin-top!"))
|
|
(define set-margin-top!
|
|
(lambda args
|
|
(apply set-margin-top-raw! args)))
|
|
(define set-margin-top-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-margin-top! elt s)))
|
|
(define margin-bottom-raw
|
|
(style:make-auto-or-css-getter elt
|
|
mxprims:element-margin-bottom
|
|
"margin-bottom"))
|
|
(define margin-bottom
|
|
(lambda args
|
|
(apply margin-bottom-raw args)))
|
|
(define margin-bottom-native
|
|
(lambda ()
|
|
(mxprims:element-margin-bottom elt)))
|
|
(define set-margin-bottom-raw!
|
|
(style:make-auto-or-css-setter elt
|
|
mxprims:element-set-margin-bottom!
|
|
"set-margin-bottom!"))
|
|
(define set-margin-bottom!
|
|
(lambda args
|
|
(apply set-margin-bottom-raw! args)))
|
|
(define set-margin-bottom-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-margin-bottom! elt s)))
|
|
(define margin-left-raw
|
|
(style:make-auto-or-css-getter elt
|
|
mxprims:element-margin-left
|
|
"margin-left"))
|
|
(define margin-left
|
|
(lambda args
|
|
(apply margin-left-raw args)))
|
|
(define margin-left-native
|
|
(lambda ()
|
|
(mxprims:element-margin-left elt)))
|
|
(define set-margin-left-raw!
|
|
(style:make-auto-or-css-setter elt
|
|
mxprims:element-set-margin-left!
|
|
"set-margin-left!"))
|
|
(define set-margin-left!
|
|
(lambda args
|
|
(apply set-margin-left-raw! args)))
|
|
(define set-margin-left-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-margin-left! elt s)))
|
|
(define margin-right-raw
|
|
(style:make-auto-or-css-getter elt
|
|
mxprims:element-margin-right
|
|
"margin-right"))
|
|
(define margin-right
|
|
(lambda args
|
|
(apply margin-right-raw args)))
|
|
(define margin-right-native
|
|
(lambda ()
|
|
(mxprims:element-margin-right elt)))
|
|
(define set-margin-right-raw!
|
|
(style:make-auto-or-css-setter elt
|
|
mxprims:element-set-margin-right!
|
|
"set-margin-right!"))
|
|
(define set-margin-right!
|
|
(lambda args
|
|
(apply set-margin-right-raw! args)))
|
|
(define set-margin-right-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-margin-right! elt s)))
|
|
(define padding-top-raw
|
|
(style:make-css-getter elt
|
|
mxprims:element-padding-top "padding-top"))
|
|
(define padding-top
|
|
(lambda args
|
|
(apply padding-top-raw args)))
|
|
(define padding-top-native
|
|
(lambda ()
|
|
(mxprims:element-padding-top elt)))
|
|
(define set-padding-top-raw!
|
|
(style:make-css-setter elt
|
|
mxprims:element-set-padding-top! "set-padding-top!"))
|
|
(define set-padding-top!
|
|
(lambda args
|
|
(apply set-padding-top-raw! args)))
|
|
(define set-padding-top-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-padding-top! elt s)))
|
|
(define padding-bottom-raw
|
|
(style:make-css-getter elt
|
|
mxprims:element-padding-bottom "padding-bottom"))
|
|
(define padding-bottom
|
|
(lambda args
|
|
(apply padding-bottom-raw args)))
|
|
(define padding-bottom-native
|
|
(lambda ()
|
|
(mxprims:element-padding-bottom elt)))
|
|
(define set-padding-bottom-raw!
|
|
(style:make-css-setter elt
|
|
mxprims:element-set-padding-bottom! "set-padding-bottom!"))
|
|
(define set-padding-bottom!
|
|
(lambda args
|
|
(apply set-padding-bottom-raw! args)))
|
|
(define set-padding-bottom-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-padding-bottom! elt s)))
|
|
(define padding-left-raw
|
|
(style:make-css-getter elt
|
|
mxprims:element-padding-left "padding-left"))
|
|
(define padding-left
|
|
(lambda args
|
|
(apply padding-left-raw args)))
|
|
(define padding-left-native
|
|
(lambda ()
|
|
(mxprims:element-padding-left elt)))
|
|
(define set-padding-left-raw!
|
|
(style:make-css-setter elt
|
|
mxprims:element-set-padding-left! "set-padding-left!"))
|
|
(define set-padding-left!
|
|
(lambda args
|
|
(apply set-padding-left-raw! args)))
|
|
(define set-padding-left-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-padding-left! elt s)))
|
|
(define padding-right-raw
|
|
(style:make-css-getter elt
|
|
mxprims:element-padding-right "padding-right"))
|
|
(define padding-right
|
|
(lambda args
|
|
(apply padding-right-raw args)))
|
|
(define padding-right-native
|
|
(lambda ()
|
|
(mxprims:element-padding-right elt)))
|
|
(define set-padding-right-raw!
|
|
(style:make-css-setter elt
|
|
mxprims:element-set-padding-right! "set-padding-right!"))
|
|
(define set-padding-right!
|
|
(lambda args
|
|
(apply set-padding-right-raw! args)))
|
|
(define set-padding-right-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-padding-right! elt s)))
|
|
(define width-raw
|
|
(style:make-auto-or-css-getter
|
|
elt mxprims:element-width "width"))
|
|
(define width
|
|
(lambda args
|
|
(apply width-raw args)))
|
|
(define width-native
|
|
(lambda ()
|
|
(mxprims:element-width elt)))
|
|
(define set-width-raw!
|
|
(style:make-auto-or-css-setter
|
|
elt mxprims:element-set-width!
|
|
"set-width!"))
|
|
(define set-width!
|
|
(lambda args
|
|
(apply set-width-raw! args)))
|
|
(define set-width-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-width! elt s)))
|
|
(define height-raw
|
|
(style:make-auto-or-css-getter
|
|
elt mxprims:element-height "height"))
|
|
(define height
|
|
(lambda args
|
|
(apply height-raw args)))
|
|
(define height-native
|
|
(lambda ()
|
|
(mxprims:element-height elt)))
|
|
(define set-height-raw!
|
|
(style:make-auto-or-css-setter
|
|
elt mxprims:element-set-height!
|
|
"set-height!"))
|
|
(define set-height!
|
|
(lambda args
|
|
(apply set-height-raw! args)))
|
|
(define set-height-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-height! elt s)))
|
|
(define top-raw
|
|
(style:make-auto-or-css-getter
|
|
elt mxprims:element-top "top"))
|
|
(define top
|
|
(lambda args
|
|
(apply top-raw args)))
|
|
(define top-native
|
|
(lambda ()
|
|
(mxprims:element-top elt)))
|
|
(define set-top-raw!
|
|
(style:make-auto-or-css-setter
|
|
elt mxprims:element-set-top!
|
|
"set-top!"))
|
|
(define set-top!
|
|
(lambda args
|
|
(apply set-top-raw! args)))
|
|
(define set-top-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-top! elt s)))
|
|
(define left-raw
|
|
(style:make-auto-or-css-getter
|
|
elt mxprims:element-left "left"))
|
|
(define left
|
|
(lambda args
|
|
(apply left-raw args)))
|
|
(define left-native
|
|
(lambda ()
|
|
(mxprims:element-left elt)))
|
|
(define set-left-raw!
|
|
(style:make-auto-or-css-setter
|
|
elt
|
|
mxprims:element-set-left!
|
|
"set-left!"))
|
|
(define set-left!
|
|
(lambda args
|
|
(apply set-left-raw! args)))
|
|
(define set-left-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-left! elt s)))
|
|
(define z-index
|
|
(lambda ()
|
|
(let ([s (mxprims:element-z-index elt)])
|
|
(when (empty-string? s)
|
|
(empty-property-error "z-index"))
|
|
(if (and (string? s) (string=? s "auto"))
|
|
'auto
|
|
s))))
|
|
(define z-index-native
|
|
(lambda ()
|
|
(mxprims:element-z-index elt)))
|
|
(define set-z-index!
|
|
(lambda (zi)
|
|
(let ([s (cond
|
|
[(eq? zi 'auto) "auto"]
|
|
[(and (number? zi)
|
|
(exact? zi)) zi]
|
|
[else
|
|
(error
|
|
(string-append "set-z-index!: "
|
|
"Expected 'auto or exact integer, "
|
|
"got")
|
|
zi)])])
|
|
(mxprims:element-set-z-index! elt s))))
|
|
(define set-z-index-native!
|
|
(lambda (s)
|
|
(mxprims:element-set-z-index! elt s)))
|
|
(define set-list-style-position-raw!
|
|
(style:make-element-setter elt
|
|
list-style-position?
|
|
*list-style-positions*
|
|
mxprims:element-set-list-style-position!))
|
|
(define set-list-style-position!
|
|
(lambda args
|
|
(apply set-list-style-position-raw! args)))
|
|
(define set-list-style-type-raw!
|
|
(style:make-element-setter elt
|
|
list-style-type?
|
|
*list-style-types*
|
|
mxprims:element-set-list-style-type!))
|
|
(define set-list-style-type!
|
|
(lambda args
|
|
(apply set-list-style-type-raw! args)))
|
|
(super-make-object)))
|
|
|
|
(define mx-event%
|
|
(class object% (init dhtml-event)
|
|
|
|
; private fields
|
|
|
|
(define event dhtml-event)
|
|
|
|
(public
|
|
keypress?
|
|
keydown?
|
|
keyup?
|
|
mousedown?
|
|
mousemove?
|
|
mouseover?
|
|
mouseout?
|
|
mouseup?
|
|
click?
|
|
dblclick?
|
|
error?
|
|
tag
|
|
id
|
|
from-tag
|
|
from-id
|
|
to-tag
|
|
to-id
|
|
keycode
|
|
shift-key
|
|
ctrl-key
|
|
alt-key
|
|
x
|
|
y)
|
|
|
|
; predicates
|
|
|
|
(define keypress? (lambda () (mxprims:event-keypress? event)))
|
|
(define keydown? (lambda () (mxprims:event-keydown? event)))
|
|
(define keyup? (lambda () (mxprims:event-keyup? event)))
|
|
(define mousedown? (lambda () (mxprims:event-mousedown? event)))
|
|
(define mousemove? (lambda () (mxprims:event-mousemove? event)))
|
|
(define mouseover? (lambda () (mxprims:event-mouseover? event)))
|
|
(define mouseout? (lambda () (mxprims:event-mouseout? event)))
|
|
(define mouseup? (lambda () (mxprims:event-mouseup? event)))
|
|
(define click? (lambda () (mxprims:event-click? event)))
|
|
(define dblclick? (lambda () (mxprims:event-dblclick? event)))
|
|
(define error? (lambda () (mxprims:event-error? event)))
|
|
|
|
; attributes
|
|
|
|
(define tag (lambda () (mxprims:event-tag event)))
|
|
(define id (lambda () (mxprims:event-id event)))
|
|
(define from-tag (lambda () (mxprims:event-from-tag event)))
|
|
(define from-id (lambda () (mxprims:event-id event)))
|
|
(define to-tag (lambda () (mxprims:event-to-tag event)))
|
|
(define to-id (lambda () (mxprims:event-to-id event)))
|
|
(define keycode (lambda () (mxprims:event-keycode event)))
|
|
(define shift-key (lambda () (mxprims:event-shiftkey event)))
|
|
(define ctrl-key (lambda () (mxprims:event-ctrlkey event)))
|
|
(define alt-key (lambda () (mxprims:event-altkey event)))
|
|
(define x (lambda () (mxprims:event-x event)))
|
|
(define y (lambda () (mxprims:event-y event)))
|
|
(super-make-object)))
|
|
|
|
(define mx-event<%> (class->interface mx-event%))
|
|
|
|
(define mx-browser%
|
|
(class object% (init (label "MysterX")
|
|
(width 'default)
|
|
(height 'default)
|
|
(x 'default)
|
|
(y 'default)
|
|
(style-options null))
|
|
|
|
; private fields
|
|
(define browser (mxprims:make-browser label width height x y style-options))
|
|
(define thread-sem (make-semaphore 1))
|
|
(define thread-wait (lambda () (semaphore-wait thread-sem)))
|
|
(define thread-post (lambda () (semaphore-post thread-sem)))
|
|
(define navigate-sem (make-semaphore 0))
|
|
(define navigate-mutex (make-semaphore 1))
|
|
(define navigate-url #f)
|
|
(define handler-sem (make-semaphore 1))
|
|
(define handler-wait (lambda () (semaphore-wait handler-sem)))
|
|
(define handler-post (lambda () (semaphore-post handler-sem)))
|
|
(define handler-table (make-hash-table))
|
|
(define handler-thread #f)
|
|
(define make-navigator
|
|
(lambda (navigate-fun name)
|
|
(lambda url
|
|
(let ([actual-url #f])
|
|
(semaphore-wait navigate-mutex)
|
|
(if (apply navigate-fun (cons browser url))
|
|
(begin
|
|
(semaphore-wait navigate-sem)
|
|
(set! actual-url navigate-url))
|
|
(begin (semaphore-post navigate-mutex)
|
|
(error name "Error navigating browser")))
|
|
(semaphore-post navigate-mutex)
|
|
actual-url))))
|
|
(define block-until-event
|
|
(lambda () (mxprims:block-until-event browser)))
|
|
(define make-event-key
|
|
(lambda (tag id) ; string x string -> symbol
|
|
(let ([new-tag (string-copy tag)]
|
|
[new-id (string-copy id)])
|
|
(string-uppercase! new-tag)
|
|
(string-uppercase! new-id)
|
|
(string->symbol
|
|
(string-append new-tag "@" new-id)))))
|
|
|
|
(public
|
|
show
|
|
navigate
|
|
navigate/status
|
|
go-back
|
|
go-forward
|
|
refresh
|
|
iconize
|
|
restore
|
|
current-url
|
|
current-document
|
|
print-document
|
|
register-event-handler
|
|
unregister-event-handler
|
|
handle-events
|
|
stop-handling-events)
|
|
|
|
(define show
|
|
(lambda (b)
|
|
(mxprims:browser-show browser b)))
|
|
(define navigate/status
|
|
(lambda (url)
|
|
(let ([actual (navigate url)])
|
|
(if (and (>= (string-length actual) 7)
|
|
(string=? (substring actual 0 7)
|
|
"http://"))
|
|
(let* ([p (get-impure-port (string->url actual))]
|
|
[response (read-line p)]
|
|
[raw-status
|
|
(regexp-match "[0-9][0-9][0-9]" response)])
|
|
(close-input-port p)
|
|
(list actual
|
|
(if raw-status
|
|
(string->number (car raw-status))
|
|
#f)))
|
|
(list actual 'no-status)))))
|
|
(define navigate-raw
|
|
(make-navigator mxprims:navigate 'navigate))
|
|
(define navigate
|
|
(lambda args
|
|
(apply navigate-raw args)))
|
|
(define go-back-raw
|
|
(make-navigator mxprims:go-back 'go-back))
|
|
(define go-back
|
|
(lambda args
|
|
(apply go-back-raw args)))
|
|
(define go-forward-raw
|
|
(make-navigator mxprims:go-forward 'go-forward))
|
|
(define go-forward
|
|
(lambda args
|
|
(apply go-forward-raw args)))
|
|
(define refresh
|
|
(lambda () (mxprims:refresh browser)))
|
|
(define iconize
|
|
(lambda () (mxprims:iconize browser)))
|
|
(define restore
|
|
(lambda () (mxprims:restore browser)))
|
|
(define current-url
|
|
(lambda ()
|
|
(mxprims:current-url browser)))
|
|
(define current-document
|
|
(lambda ()
|
|
(make-object mx-document%
|
|
(mxprims:current-document browser))))
|
|
(define print-document
|
|
(lambda ()
|
|
(mxprims:print-document browser)))
|
|
(define register-event-handler
|
|
(lambda (elt fn)
|
|
(dynamic-wind
|
|
handler-wait
|
|
(lambda ()
|
|
(let* ([tag (send elt tag)]
|
|
[id (send elt attribute "id")])
|
|
(let ([key (make-event-key tag id)])
|
|
(hash-table-remove! handler-table key)
|
|
(hash-table-put! handler-table key fn))))
|
|
handler-post)))
|
|
(define unregister-event-handler
|
|
(lambda (elt)
|
|
(dynamic-wind
|
|
handler-wait
|
|
(lambda ()
|
|
(let* ([tag (send elt tag)]
|
|
[id (send elt attribute "id")])
|
|
(let ([key (make-event-key tag id)])
|
|
(hash-table-remove! handler-table key))))
|
|
handler-post)))
|
|
(define handle-events
|
|
(lambda ()
|
|
(dynamic-wind
|
|
thread-wait
|
|
(lambda () ; no-op if existing handler-thread
|
|
(unless handler-thread
|
|
(dynamic-wind
|
|
handler-wait
|
|
(lambda ()
|
|
(let* ([handler-thunk
|
|
(lambda ()
|
|
(let loop ()
|
|
(block-until-event)
|
|
(let* ([prim-event
|
|
(with-handlers
|
|
([void
|
|
(lambda (e)
|
|
(printf "~a~n" (exn-message e))
|
|
(loop))])
|
|
(mxprims:get-event browser))]
|
|
[event (make-object mx-event% prim-event)]
|
|
[tag (send event tag)]
|
|
[id (send event id)]
|
|
[key (make-event-key tag id)]
|
|
[handler (hash-table-get handler-table key void)])
|
|
(unless (void? handler)
|
|
(handler event))
|
|
(loop))))])
|
|
(set! handler-thread (thread handler-thunk))))
|
|
handler-post)))
|
|
thread-post)))
|
|
(define stop-handling-events
|
|
(lambda ()
|
|
(dynamic-wind
|
|
thread-wait
|
|
(lambda ()
|
|
(when handler-thread
|
|
(kill-thread handler-thread))
|
|
(set! handler-thread #f))
|
|
thread-post)))
|
|
|
|
(super-make-object)
|
|
(mxprims:register-navigate-handler
|
|
browser
|
|
(lambda (_ boxed-url)
|
|
(set! navigate-url (current-url))
|
|
(semaphore-post navigate-sem)))))
|
|
|
|
(define mx-document%
|
|
(class object%
|
|
(init the-doc)
|
|
|
|
; private fields
|
|
|
|
(define doc the-doc)
|
|
|
|
(define insert-object-maker
|
|
(lambda (name->html)
|
|
(opt-lambda
|
|
(object width height [size 'pixels])
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda ()
|
|
(mxprims:document-insert-html
|
|
doc
|
|
(name->html object width height size))
|
|
(car (mxprims:document-objects doc)))
|
|
html-post))))
|
|
|
|
(define append-object-maker
|
|
(lambda (name->html)
|
|
(opt-lambda
|
|
(object width height [size 'pixels])
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda ()
|
|
(mxprims:document-append-html
|
|
doc
|
|
(name->html object width height size))
|
|
(car (mzlib:last-pair (mxprims:document-objects doc))))
|
|
html-post))))
|
|
|
|
(define html-insertion-maker
|
|
(lambda (f)
|
|
(lambda (s)
|
|
(dynamic-wind
|
|
html-wait
|
|
(lambda () (f doc s))
|
|
html-post))))
|
|
|
|
(public
|
|
title
|
|
find-element
|
|
find-element-by-id-or-name
|
|
elements-with-tag
|
|
objects
|
|
insert-html
|
|
append-html
|
|
replace-html
|
|
insert-object-from-coclass
|
|
append-object-from-coclass
|
|
insert-object-from-progid
|
|
append-object-from-progid)
|
|
|
|
(define title
|
|
(lambda ()
|
|
(mxprims:document-title doc)))
|
|
(define find-element
|
|
(lambda (tag id . n)
|
|
(make-object mx-element% doc
|
|
(apply mxprims:document-find-element
|
|
doc tag id n))))
|
|
(define find-element-by-id-or-name
|
|
(lambda (id . n)
|
|
(make-object
|
|
mx-element% doc
|
|
(apply mxprims:document-find-element-by-id-or-name
|
|
doc id n))))
|
|
(define elements-with-tag
|
|
(lambda (tag)
|
|
(map
|
|
(lambda (elt)
|
|
(make-object mx-element% doc elt))
|
|
(mxprims:document-elements-with-tag doc tag))))
|
|
(define objects
|
|
(lambda ()
|
|
(mxprims:document-objects doc)))
|
|
(define insert-html-raw
|
|
(html-insertion-maker mxprims:document-insert-html))
|
|
(define insert-html
|
|
(lambda args
|
|
(apply insert-html-raw args)))
|
|
(define append-html-raw
|
|
(html-insertion-maker mxprims:document-append-html))
|
|
(define append-html
|
|
(lambda args
|
|
(apply append-html-raw args)))
|
|
(define replace-html-raw
|
|
(html-insertion-maker mxprims:document-replace-html))
|
|
(define replace-html
|
|
(lambda args
|
|
(apply replace-html-raw args)))
|
|
(define insert-object-from-coclass-raw
|
|
(insert-object-maker coclass->html))
|
|
(define insert-object-from-coclass
|
|
(lambda args
|
|
(apply insert-object-from-coclass-raw args)))
|
|
(define append-object-from-coclass-raw
|
|
(append-object-maker coclass->html))
|
|
(define append-object-from-coclass
|
|
(lambda args
|
|
(apply append-object-from-coclass-raw args)))
|
|
(define insert-object-from-progid-raw
|
|
(insert-object-maker progid->html))
|
|
(define insert-object-from-progid
|
|
(lambda args
|
|
(apply insert-object-from-progid-raw args)))
|
|
(define append-object-from-progid-raw
|
|
(append-object-maker progid->html))
|
|
(define append-object-from-progid
|
|
(lambda args
|
|
(apply append-object-from-progid-raw args)))
|
|
|
|
(super-make-object)))
|
|
|
|
(define mx-document<%> (class->interface mx-document%))
|
|
|
|
(thread
|
|
(lambda ()
|
|
(let loop ()
|
|
(mxprims:process-win-events)
|
|
(sleep 0.01)
|
|
(loop)))))
|