-
This commit is contained in:
@@ -16,6 +16,9 @@
|
||||
xml
|
||||
xml/xexpr
|
||||
json
|
||||
(prefix-in g: gregor)
|
||||
(prefix-in g: gregor/time)
|
||||
gregor-utils
|
||||
)
|
||||
|
||||
(provide webview-create
|
||||
@@ -37,6 +40,18 @@
|
||||
webview-set-title!
|
||||
|
||||
webview-choose-dir
|
||||
webview-file-open
|
||||
webview-file-save
|
||||
wv-permitted-exts
|
||||
|
||||
make-wv-permitted-exts
|
||||
wv-permitted-exts-name
|
||||
wv-permitted-exts-exts
|
||||
set-wv-permitted-exts-exts!
|
||||
set-wv-permitted-exts-name!
|
||||
wv-permitted-exts?
|
||||
wv-permitted-exts-exts?
|
||||
wv-list-of-permitted-exts?
|
||||
|
||||
webview-bind!
|
||||
|
||||
@@ -44,14 +59,16 @@
|
||||
webview-set-html!
|
||||
|
||||
webview-set-innerHTML!
|
||||
|
||||
webview-set-value!
|
||||
|
||||
webview-value
|
||||
webview-value/bool
|
||||
webview-value/symbol
|
||||
webview-value/number
|
||||
;webview-value/date
|
||||
;webview-value/time
|
||||
;webview-value/datetime
|
||||
webview-value/date
|
||||
webview-value/time
|
||||
webview-value/datetime
|
||||
|
||||
webview-add-class!
|
||||
webview-remove-class!
|
||||
@@ -60,12 +77,12 @@
|
||||
|
||||
webview-set-attr!
|
||||
webview-attr
|
||||
;webview-attr/bool
|
||||
;webview-attr/symbol
|
||||
;webview-attr/number
|
||||
;webview-attr/date
|
||||
;webview-attr/time
|
||||
;webview-attr/datetime
|
||||
webview-attr/bool
|
||||
webview-attr/symbol
|
||||
webview-attr/number
|
||||
webview-attr/date
|
||||
webview-attr/time
|
||||
webview-attr/datetime
|
||||
|
||||
;webview-del-attr!
|
||||
|
||||
@@ -192,6 +209,63 @@
|
||||
(esc-quote selector)
|
||||
func))))
|
||||
|
||||
(define (make-exts-filter list-of-pe)
|
||||
(define (mef pe)
|
||||
(format "~a ~a"
|
||||
(wv-permitted-exts-name pe)
|
||||
(map (λ (e) (format "*.~a" e)) (wv-permitted-exts-exts pe))))
|
||||
(string-join (map mef (if (list? list-of-pe) list-of-pe (list list-of-pe))) ";;"))
|
||||
|
||||
(define (filter->exts str)
|
||||
(let ((re #px"^([^ ]+)\\s+[(]([^)]+)[)]"))
|
||||
(let ((m (regexp-match re str)))
|
||||
(cond ((eq? m #f)
|
||||
#f)
|
||||
(else (let* ((re1 #px"\\s+")
|
||||
(re2 #px"[*][.](.*)")
|
||||
(exts (regexp-split re1 (caddr m))))
|
||||
(make-wv-permitted-exts (cadr m)
|
||||
(map (λ (e)
|
||||
(let ((m (regexp-match re2 e)))
|
||||
(string->symbol (cadr m))))
|
||||
exts))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Data structures
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-struct wv-permitted-exts
|
||||
((name #:mutable) (exts #:mutable))
|
||||
#:transparent
|
||||
)
|
||||
|
||||
(define (wv-permitted-exts-exts? e)
|
||||
(list-of? symbol? e))
|
||||
|
||||
(define (wv-permitted-exts-name? e)
|
||||
(string? e))
|
||||
|
||||
(define wv-pm-exts? wv-permitted-exts?)
|
||||
|
||||
(set! wv-permitted-exts? (λ (e)
|
||||
(and (wv-pm-exts? e)
|
||||
(wv-permitted-exts-exts? (wv-permitted-exts-exts e))
|
||||
(wv-permitted-exts-name? (wv-permitted-exts-name e))
|
||||
)))
|
||||
|
||||
(define (wv-list-of-permitted-exts? l)
|
||||
(list-of? (λ (e) (and
|
||||
(wv-permitted-exts? e)
|
||||
(wv-permitted-exts-exts? (wv-permitted-exts-exts e))))
|
||||
l))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Webview functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@@ -267,18 +341,45 @@
|
||||
(if (eq? res #f)
|
||||
#f
|
||||
(cond ((eq? (car res) 'oke)
|
||||
(let ((h (fromJson (cadr res))))
|
||||
(let ((r (make-hash)))
|
||||
(hash-set! r 'dir (hash-ref h 'dir))
|
||||
(hash-set! r 'state (string->symbol
|
||||
(hash-ref h 'state)))
|
||||
r)))
|
||||
(let ((r (make-hash (hash->list (fromJson (cadr res))))))
|
||||
(hash-set! r 'state (string->symbol (hash-ref r 'state)))
|
||||
r))
|
||||
(else #f))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define (file-open-save wv title base-dir permitted-exts open-save-f)
|
||||
(let* ((bd (if (path? base-dir) (path->string base-dir) base-dir))
|
||||
(ext-filter (make-exts-filter permitted-exts)))
|
||||
(let ((res (open-save-f (wv-handle wv) title bd ext-filter)))
|
||||
(if (eq? res #f)
|
||||
#f
|
||||
(cond ((eq? (car res) 'oke)
|
||||
(let* ((h (make-hash (hash->list (fromJson (cadr res))))))
|
||||
(hash-set! h 'state (string->symbol (hash-ref h 'state)))
|
||||
(hash-set! h 'used-filter (filter->exts (hash-ref h 'used-filter)))
|
||||
h))
|
||||
(else #f))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(define/contract (webview-file-open wv title base-dir permitted-exts)
|
||||
(-> wv? string? (or/c path? string?) (or/c wv-permitted-exts? wv-list-of-permitted-exts?)
|
||||
(or/c hash? boolean?))
|
||||
(file-open-save wv title base-dir permitted-exts rkt-webview-file-open))
|
||||
|
||||
(define/contract (webview-file-save wv title base-dir permitted-exts)
|
||||
(-> wv? string? (or/c path? string?) (or/c wv-permitted-exts? wv-list-of-permitted-exts?)
|
||||
(or/c hash? boolean?))
|
||||
(file-open-save wv title base-dir permitted-exts rkt-webview-file-save))
|
||||
|
||||
|
||||
|
||||
(define/contract (webview-set-title! wv title)
|
||||
(-> wv? string? symbol?)
|
||||
(rkt-webview-set-title! (wv-handle wv) title))
|
||||
@@ -351,7 +452,7 @@
|
||||
)
|
||||
|
||||
(define/contract (webview-set-value! wv id val)
|
||||
(-> wv? symbol? (or/c symbol? string? number? boolean?) symbol?)
|
||||
(-> wv? symbol? (or/c symbol? string? number? boolean? g:date? g:time? g:datetime?) symbol?)
|
||||
(webview-run-js wv
|
||||
(with-id id el
|
||||
((string-append
|
||||
@@ -361,7 +462,17 @@
|
||||
" el.value = '~a';\n"
|
||||
"}")
|
||||
(if (eq? val #f) "false" "true")
|
||||
(esc-quote (format "~a" val))))
|
||||
(cond
|
||||
([(g:date? val)]
|
||||
(date->string val))
|
||||
([(g:time? val)]
|
||||
(time->string val))
|
||||
([(g:datetime? val)]
|
||||
(datetime->string val))
|
||||
(else
|
||||
(esc-quote (format "~a" val))))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
@@ -381,28 +492,26 @@
|
||||
#f
|
||||
v)))
|
||||
|
||||
(define/contract (webview-value/number wv id)
|
||||
(-> wv? symbol? (or/c number? boolean?))
|
||||
(let ((v (webview-value wv id)))
|
||||
(if (eq? v #f)
|
||||
#f
|
||||
(string->number (webview-value wv id)))))
|
||||
(define-syntax wvv
|
||||
(syntax-rules ()
|
||||
((_ name type-pred? convert)
|
||||
(define/contract (name wv id)
|
||||
(-> wv? symbol? (or/c type-pred? boolean?))
|
||||
(let ((v (webview-value wv id)))
|
||||
(if (eq? v #f)
|
||||
#f
|
||||
(convert v))))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define/contract (webview-value/symbol wv id)
|
||||
(-> wv? symbol? (or/c symbol? boolean?))
|
||||
(let ((v (webview-value wv id)))
|
||||
(if (eq? v #f)
|
||||
#f
|
||||
(string->symbol (webview-value wv id)))))
|
||||
(wvv webview-value/time g:time? string->time)
|
||||
(wvv webview-value/date g:date? string->date)
|
||||
(wvv webview-value/datetime g:datetime? string->datetime)
|
||||
(wvv webview-value/number number? string->number)
|
||||
(wvv webview-value/symbol symbol? string->symbol)
|
||||
(wvv webview-value/bool boolean? (λ (e) (if (string=? e "true") #t #f)))
|
||||
|
||||
(define/contract (webview-value/bool wv id)
|
||||
(-> wv? symbol? (or/c symbol? boolean?))
|
||||
(let ((v (webview-value wv id)))
|
||||
(if (eq? v #f)
|
||||
'fail
|
||||
(if (string=? (webview-value wv id) "true")
|
||||
#t
|
||||
#f))))
|
||||
|
||||
(define/contract (webview-add-class! wv id-or-selector class)
|
||||
(-> wv? (or/c symbol? string?) (or/c symbol? string? list?) hash?)
|
||||
@@ -496,13 +605,22 @@
|
||||
)
|
||||
|
||||
(define/contract (webview-set-attr! wv selector attr-entries)
|
||||
(-> wv? (or/c symbol? string?) (or/c kv? list-of-kv?) hash?)
|
||||
(let ((sel (if (symbol? selector)
|
||||
(format "#~a" selector)
|
||||
selector))
|
||||
(cl (mk-js-array (if (kv? attr-entries)
|
||||
(list attr-entries)
|
||||
attr-entries)))
|
||||
(-> wv? (or/c symbol? string?)
|
||||
(or/c kv? list-of-kv?) hash?)
|
||||
(let* ((sel (if (symbol? selector)
|
||||
(format "#~a" selector)
|
||||
selector))
|
||||
(ae* (if (kv? attr-entries) (list attr-entries) attr-entries))
|
||||
(ae** (map (λ (kv)
|
||||
(let ((v (kv-2 kv)))
|
||||
(make-kv (kv-1 kv)
|
||||
(cond
|
||||
([g:date? v] (date->string v))
|
||||
([g:time? v] (time->string v))
|
||||
([g:datetime? v] (datetime->string v))
|
||||
(else (format "~a" v))))
|
||||
)) ae*))
|
||||
(cl (mk-js-array ae**))
|
||||
)
|
||||
(webview-call-js wv
|
||||
(with-selector sel
|
||||
@@ -531,39 +649,25 @@
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
#|(define/contract (webview-set-style! wv selector style-entries)
|
||||
(-> wv? (or/c symbol? string?) (or/c list? list-of-kv?) hash?)
|
||||
|
||||
(define (webview-set-style!* wv selector h)
|
||||
(list wv selector h))
|
||||
|
||||
|
||||
(define-syntax webview-style-entry
|
||||
(define-syntax wva
|
||||
(syntax-rules ()
|
||||
((_ h (k v))
|
||||
(with-handlers ([exn:fail? (λ (e)
|
||||
(hash-set! h 'k v))])
|
||||
(hash-set! h k v)))
|
||||
((_ h q l)
|
||||
(hash-set! h (car l) (cadr l)))
|
||||
((_ h l)
|
||||
(hash-set! h (car l) (cadr l)))
|
||||
)
|
||||
)
|
||||
|
||||
(define-syntax webview-set-style!
|
||||
(syntax-rules ()
|
||||
((_ wv selector st ...)
|
||||
(webview-set-style!* wv selector
|
||||
(let ((h (make-hash)))
|
||||
(webview-style-entry h st)
|
||||
...
|
||||
h))
|
||||
((_ name type-pred? convert)
|
||||
(define/contract (name wv id attr)
|
||||
(-> wv? symbol? (or/c symbol? string?) (or/c type-pred? boolean?))
|
||||
(let ((v (webview-attr wv id attr)))
|
||||
(if (eq? v #f)
|
||||
#f
|
||||
(convert v))))
|
||||
)
|
||||
)
|
||||
)
|
||||
|#
|
||||
|
||||
(wva webview-attr/number number? string->number)
|
||||
(wva webview-attr/symbol symbol? string->symbol)
|
||||
(wva webview-attr/date g:date? string->date)
|
||||
(wva webview-attr/time g:time? string->time)
|
||||
(wva webview-attr/datetime g:datetime string->datetime)
|
||||
(wvv webview-attr/bool boolean? (λ (e) (if (string=? e "true") #t #f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; testing
|
||||
|
||||
Reference in New Issue
Block a user