Hans Dijkema
5811df919c
with the DrRacket WxWidgets base, which is also Gtk. So this will never work reliable. We're going back to inter process communication instead of integrating on library/FFI/thread level. Signed-off-by: Hans Dijkema <hans@dijkewijk.nl>
941 lines
27 KiB
Racket
941 lines
27 KiB
Racket
(module web-wire racket/base
|
|
|
|
(require racket/system
|
|
racket/file
|
|
racket/gui
|
|
racket/port
|
|
data/queue
|
|
json
|
|
"../utils/utils.rkt"
|
|
"css.rkt"
|
|
"menu.rkt"
|
|
"webui-wire-ffi.rkt"
|
|
"webui-wire-download.rkt"
|
|
)
|
|
|
|
(provide ww-start
|
|
ww-stop
|
|
|
|
ww-set-debug
|
|
ww-debug
|
|
ww-error
|
|
ww-display-log
|
|
|
|
ww-cmd
|
|
ww-cmd-nok?
|
|
|
|
ww-protocol
|
|
ww-log-level
|
|
ww-set-stylesheet
|
|
ww-get-stylesheet
|
|
|
|
ww-new
|
|
ww-close
|
|
|
|
ww-move
|
|
ww-resize
|
|
ww-set-title
|
|
ww-set-icon
|
|
|
|
ww-set-menu
|
|
|
|
ww-set-html
|
|
ww-set-url
|
|
|
|
ww-set-inner-html
|
|
ww-get-inner-html
|
|
|
|
ww-set-attr
|
|
ww-get-attr
|
|
ww-get-attrs
|
|
ww-del-attr
|
|
|
|
ww-set-style
|
|
ww-add-style
|
|
ww-get-style
|
|
|
|
ww-add-class
|
|
ww-remove-class
|
|
ww-has-class?
|
|
|
|
ww-set-value
|
|
ww-get-value
|
|
|
|
ww-get-elements
|
|
|
|
ww-set-show-state
|
|
ww-get-show-state
|
|
|
|
ww-bind
|
|
ww-on
|
|
ww-element-info
|
|
|
|
ww-file-open
|
|
ww-file-save
|
|
ww-choose-dir
|
|
|
|
windows
|
|
windows-evt-handlers
|
|
ww-get-window-for-id
|
|
|
|
ww-from-string
|
|
|
|
ww-win-id
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Some utils
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (drop expected s)
|
|
(let ((e (string-append expected ":")))
|
|
(if (string-prefix? s e)
|
|
(substring s (string-length e))
|
|
#f)))
|
|
|
|
(define (as-string s)
|
|
(let ((s* (format "~a" s)))
|
|
(with-output-to-string (lambda () (write s*)))))
|
|
|
|
(define (ww-from-string s)
|
|
(let ((s* (substring s 1 (- (string-length s) 1))))
|
|
(string-replace s* "\\\"" "\"")))
|
|
|
|
(define (to-server-file html-file)
|
|
(let* ((path (build-path html-file))
|
|
(complete-p (path->complete-path path))
|
|
(a-file (format "~a" complete-p))
|
|
(the-file (string-replace a-file "\\" "/")))
|
|
the-file))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; web-wire handling (interaction with the library)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define _ww-debug #f)
|
|
|
|
(define (ww-set-debug yn) (set! _ww-debug yn))
|
|
|
|
(define (do-debug str . var)
|
|
(when _ww-debug
|
|
(if (null? var)
|
|
(displayln (format "Debug: ~a" str))
|
|
(displayln (format "Debug: ~a: ~a" (car var) str))
|
|
)))
|
|
|
|
(define (err str . var)
|
|
(if (null? var)
|
|
(displayln (format "Error: ~a" str))
|
|
(displayln (format "Error: ~a: ~a" var str))
|
|
))
|
|
|
|
(define-syntax debug
|
|
(syntax-rules ()
|
|
((_ str)
|
|
(do-debug str))
|
|
((_ var str)
|
|
(do-debug str 'var))
|
|
))
|
|
|
|
(define-syntax ww-debug
|
|
(syntax-rules ()
|
|
((_ str)
|
|
(do-debug str))
|
|
((_ var str)
|
|
(do-debug str 'var))
|
|
))
|
|
|
|
(define-syntax ww-error
|
|
(syntax-rules ()
|
|
((_ str)
|
|
(err str))
|
|
((_ var str)
|
|
(err str 'var))
|
|
))
|
|
|
|
(define re-kind #px"([A-Z]+)[(]([0-9]+)[)][:]")
|
|
;(define re-event #px"([^:]+)[:]([0-9]+)([:](.*))?")
|
|
(define re-js-event #px"^([^:]+)([:](.*))?")
|
|
(define re-js-result #px"([0-9]+)[:]([^:]+)[:](.*)")
|
|
(define re-js-handle #px"([^:]+)[:]([0-9]+)[:]([0-9]+)([:](.*))?")
|
|
|
|
(define windows-evt-handlers (make-hash))
|
|
(define windows (make-hash))
|
|
|
|
(define (ww-get-window-for-id win-id)
|
|
(hash-ref windows win-id #f))
|
|
|
|
(define-struct web-rkt
|
|
([handle #:mutable]
|
|
[event-thread #:mutable]
|
|
[stop-thread #:mutable]
|
|
[reader-thread #:mutable]
|
|
)
|
|
)
|
|
|
|
(define ww-current-handle #f)
|
|
|
|
(define evt-sem (make-semaphore))
|
|
(define evt-fifo (make-queue))
|
|
(define log-fifo (make-queue))
|
|
(define log-fifo-max 100)
|
|
|
|
(define re-event #px"^([^:]+)([:]([^:]+))?")
|
|
|
|
|
|
(define (event-queuer evt)
|
|
(enqueue! evt-fifo evt)
|
|
(semaphore-post evt-sem))
|
|
|
|
(define (process-event h evt*)
|
|
(let* ((evt evt*) ;(bytes->string/utf-8 evt*))
|
|
(m (regexp-match re-event evt)))
|
|
(ww-debug evt)
|
|
(let* ((e (string->symbol (string-downcase (list-ref m 1))))
|
|
(win-id (if (eq? (list-ref m 3) #f) #f (string->number (list-ref m 3))))
|
|
(evt-handler (hash-ref windows-evt-handlers win-id #f))
|
|
(payload* (substring evt (string-length (list-ref m 0))))
|
|
(payload (if (string=? payload* "")
|
|
(make-hash)
|
|
(with-input-from-string (substring payload* 1) read-json)))
|
|
)
|
|
(if (eq? evt-handler #f)
|
|
(ww-error (format "no event handler to handle event ~a" evt))
|
|
(queue-callback (lambda () (evt-handler e payload))))
|
|
; (evt-handler e payload))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (event-handler h)
|
|
(parameterize ([current-eventspace (current-eventspace)])
|
|
(thread
|
|
(lambda ()
|
|
(letrec ((f (lambda ()
|
|
(semaphore-wait evt-sem)
|
|
(queue-callback
|
|
(lambda () (process-event h (dequeue! evt-fifo))))
|
|
(f))))
|
|
(f))))))
|
|
|
|
|
|
(define (process-log kind* msg*)
|
|
(define (ensure-fifo)
|
|
(if (> (queue-length log-fifo) log-fifo-max)
|
|
(begin
|
|
(dequeue! log-fifo)
|
|
(ensure-fifo))
|
|
(queue-length log-fifo)))
|
|
(let ((kind kind*) ;(bytes->string/utf-8 kind*))
|
|
(msg msg*)) ;(bytes->string/utf-8 msg*)))
|
|
(enqueue! log-fifo (cons kind msg))
|
|
(ensure-fifo)))
|
|
|
|
(define (ww-display-log)
|
|
(for-each (λ (item)
|
|
(displayln (format "~a - ~a" (car item) (cdr item))))
|
|
(queue->list log-fifo)))
|
|
|
|
|
|
(define (ww-start . args)
|
|
(when (eq? ww-current-handle #f)
|
|
(let ((existing-h (webwire-current)))
|
|
(let ((h (make-web-rkt (if (eq? existing-h #f)
|
|
(webwire-new)
|
|
existing-h)
|
|
#f
|
|
#f
|
|
#f)))
|
|
(unless (eq? (webwire-status (web-rkt-handle h)) 'valid)
|
|
(error (format "Invalid handle, cannot start. Reason: ~a"
|
|
(webwire-status->string
|
|
(webwire-status (web-rkt-handle h))))))
|
|
(let ((thrd (event-handler h)))
|
|
;(webwire-handlers! (web-rkt-handle h)
|
|
; event-queuer
|
|
; process-log)
|
|
(let ((reader-thread (thread (λ ()
|
|
(let loop ()
|
|
(begin
|
|
(sleep 0.01)
|
|
(let ((l (webwire-get (web-rkt-handle h))))
|
|
(let ((result (car l)))
|
|
(unless (or (eq? result 'null) (eq? result 'invalid-handle))
|
|
(let* ((evt (cadr l))
|
|
(kind (caddr l))
|
|
(msg (cadddr l)))
|
|
(unless (eq? evt #f)
|
|
(event-queuer evt))
|
|
(unless (eq? kind #f)
|
|
(process-log kind msg))))))
|
|
(loop)))
|
|
)
|
|
)))
|
|
(set-web-rkt-reader-thread! h reader-thread)
|
|
(set-web-rkt-event-thread! h thrd)
|
|
(set! ww-current-handle h))))))
|
|
(unless (null? args)
|
|
(ww-log-level (car args)))
|
|
ww-current-handle)
|
|
|
|
(define (ww-stop)
|
|
(unless (eq? ww-current-handle #f)
|
|
(let ((thr (web-rkt-event-thread ww-current-handle)))
|
|
(kill-thread thr))
|
|
;; inform event handlers of destroying of windows.
|
|
(let ((keys (hash-keys windows-evt-handlers)))
|
|
(for-each (λ (win-id)
|
|
(let ((handler (hash-ref windows-evt-handlers win-id)))
|
|
(handler 'destroyed #f)))
|
|
keys))
|
|
(webwire-destroy (web-rkt-handle ww-current-handle))
|
|
(set! ww-current-handle #f)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Commands
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;; Types
|
|
|
|
(define-struct ww-win
|
|
(id)
|
|
#:transparent)
|
|
|
|
(define-struct cmdr
|
|
(ok kind win r))
|
|
|
|
;;;;;;;;;;;; Command Utilities
|
|
|
|
(define (cmdr->list r)
|
|
(list (cmdr-ok r) (cmdr-kind r)
|
|
(cmdr-win r) (cmdr-r r)))
|
|
|
|
(define (cmdr-dbg r)
|
|
(ww-debug (cmdr->list r))
|
|
(cmdr-r r))
|
|
|
|
(define (ww-from-json result)
|
|
(hash-ref (with-input-from-string
|
|
(string-replace result "\\\"" "\"")
|
|
read-json) 'result #f))
|
|
|
|
(define re-generic-result #px"^(OK|NOK)[:]([^:]+)([:]([0-9]+))?")
|
|
|
|
(define (convert-result result)
|
|
(let ((m (regexp-match re-generic-result result)))
|
|
(ww-debug result)
|
|
(ww-debug m)
|
|
(if m
|
|
(let* ((ok (string=? (list-ref m 1) "OK"))
|
|
(kind (list-ref m 2))
|
|
(win (if (eq? (list-ref m 4) #f)
|
|
#f
|
|
(string->number (list-ref m 4))))
|
|
(r (substring result (string-length (list-ref m 0))))
|
|
)
|
|
(make-cmdr ok (string->symbol kind)
|
|
win
|
|
(if (string-prefix? r ":")
|
|
(substring r 1)
|
|
r)))
|
|
(make-cmdr #f 'parse-error #f result))
|
|
)
|
|
)
|
|
|
|
(define (check-nok cmd r)
|
|
(when (eq? (cmdr-ok r) #f)
|
|
(process-log 'CMD-NOK
|
|
(format "~a - ~a" cmd (cmdr->list r)))))
|
|
|
|
;;;;;;;;;;;; Calling commands in the web wire environment
|
|
|
|
(define (ww-cmd cmd)
|
|
(ww-debug (format "ww-cmd ~a" cmd))
|
|
(if (eq? cmd 'quit)
|
|
(let ((result (webwire-command (web-rkt-handle ww-current-handle) "exit")))
|
|
(let ((r (convert-result result)))
|
|
(check-nok cmd r)
|
|
(ww-stop)
|
|
r))
|
|
(let ((result (webwire-command (web-rkt-handle ww-current-handle) cmd)))
|
|
(let ((r (convert-result result)))
|
|
(check-nok cmd r)
|
|
r))))
|
|
|
|
(define (ww-cmd-nok? r)
|
|
(if (cmdr? r)
|
|
(eq? (cmdr-ok r) #f)
|
|
(eq? r 'cmd-nok)))
|
|
|
|
;;;;;;;;;;;; Check functions and converter functions
|
|
|
|
;;;;; Check functions
|
|
|
|
(define (stylesheet-or-string? st)
|
|
(or (stylesheet? st) (string? st)))
|
|
|
|
(define (is-icon-file? ext)
|
|
(lambda (v)
|
|
(let ((r #f))
|
|
(when (string? v)
|
|
(let ((e (string-append "." (symbol->string ext))))
|
|
(when (string-suffix? v e)
|
|
(when (file-exists? v)
|
|
(set! r #t)))))
|
|
(unless r
|
|
(error (format "Need an existing file of type ~a, got ~a"
|
|
ext v)))
|
|
r)))
|
|
|
|
(define (html-file-exists? f)
|
|
(file-exists? f))
|
|
|
|
(define (html-or-file? v)
|
|
(if (file-exists? v)
|
|
#t
|
|
(string? v)))
|
|
|
|
(define (symbol-or-string? s)
|
|
(or (symbol? s) (string? s)))
|
|
|
|
(define (any? v)
|
|
#t)
|
|
|
|
(define (selector? s)
|
|
(or (symbol? s) (string? s)
|
|
(if (list? s)
|
|
(if (null? s)
|
|
#f
|
|
(letrec ((f (λ (l)
|
|
(if (null? l)
|
|
#t
|
|
(and (or (symbol? (car l))
|
|
(string? (car l)))
|
|
(f (cdr l))))
|
|
)
|
|
))
|
|
(f s))
|
|
)
|
|
#f)
|
|
)
|
|
)
|
|
|
|
;;;;; Conversion functions
|
|
|
|
(define (to-selector v)
|
|
(if (symbol? v)
|
|
(format "#~a, ~a" v v)
|
|
(if (string? v)
|
|
v
|
|
(if (list? v)
|
|
(letrec ((f (λ (l)
|
|
(if (null? l)
|
|
""
|
|
(string-append ", " (to-selector (car l))
|
|
(f (cdr l)))))
|
|
))
|
|
(string-append (to-selector (car v))
|
|
(f (cdr v))))
|
|
""))))
|
|
|
|
(define (convert-cmd-result-to type str)
|
|
(ww-debug type)
|
|
(ww-debug str)
|
|
(cond
|
|
((or (eq? type 'number) (eq? type 'int) (eq? type 'real)) (string->number str))
|
|
((eq? type 'symbol) (string->symbol str))
|
|
((eq? type 'json) (ww-from-json str))
|
|
((eq? type 'stylesheet) (string->stylesheet str))
|
|
((eq? type 'ww-win) (make-ww-win (string->number str)))
|
|
((eq? type 'void) 'void)
|
|
((eq? type 'css-style) (string->css-style str))
|
|
(else str)))
|
|
|
|
(define (check-cmd-type v vname type typename)
|
|
(let ((is-type (type v)))
|
|
(unless is-type
|
|
(error
|
|
(format "Expected ~a of type ~a"
|
|
vname typename)))
|
|
#t))
|
|
|
|
(define (convert-arg-to-cmd v vname type)
|
|
(cond
|
|
((eq? type 'symbol?) v)
|
|
((eq? type 'string?) v)
|
|
((or (eq? type 'stylesheet?)
|
|
(eq? type 'stylesheet-or-string?))
|
|
(let* ((css (if (stylesheet? v)
|
|
(stylesheet->string v)
|
|
v))
|
|
(h (let ((h (make-hasheq)))
|
|
(hash-set! h 'css css)
|
|
h))
|
|
(json (jsexpr->string h))
|
|
)
|
|
json))
|
|
((eq? type 'ww-win?) (ww-win-id v))
|
|
((eq? type 'is-menu?) (menu->json v))
|
|
((eq? type 'html-file-exists?) (to-server-file v))
|
|
((eq? type 'html-or-file?) (if (file-exists? v)
|
|
(to-server-file v)
|
|
v))
|
|
((eq? type 'any?) (as-string v))
|
|
((eq? type 'selector?) (to-selector v))
|
|
((eq? type 'css-style?) (css-style->string v))
|
|
((eq? type 'boolean?) (if (eq? v #f) 'false 'true))
|
|
((eq? type 'symbol-or-string?) v)
|
|
((eq? type 'number?) v)
|
|
(else (begin
|
|
(ww-error (format "Convert-arg-to-cmd Unexpected: ~a ~a ~a" vname type v))
|
|
v))))
|
|
|
|
|
|
;;;; Generic syntax to define commands
|
|
(define-syntax def-cmd-check
|
|
(syntax-rules ()
|
|
((_ var type)
|
|
(check-cmd-type var 'var type 'type))
|
|
)
|
|
)
|
|
|
|
(define-syntax check-opt
|
|
(syntax-rules ()
|
|
((_ i (var type) args)
|
|
(begin
|
|
(unless (>= i (length args))
|
|
(check-cmd-type (list-ref args i)
|
|
'var
|
|
type 'type)
|
|
(set! i (+ i 1)))))
|
|
)
|
|
)
|
|
|
|
(define-syntax def-cmd-opt-checks
|
|
(syntax-rules ()
|
|
((_ (vt ...) more)
|
|
(let ((i 0))
|
|
(begin
|
|
(check-opt i vt more)
|
|
...)
|
|
(when (< i (length more))
|
|
(error "Too many arguments given"))))
|
|
)
|
|
)
|
|
|
|
(define (mk-cmd-arg* v vname type)
|
|
(let ((o (open-output-string)))
|
|
(display " " o)
|
|
(write (convert-arg-to-cmd v vname type) o)
|
|
(get-output-string o)))
|
|
|
|
(define-syntax mk-cmd-arg
|
|
(syntax-rules ()
|
|
((_ a type)
|
|
(mk-cmd-arg* a 'a 'type))))
|
|
|
|
(define-syntax mk-cmd-opt-args
|
|
(syntax-rules ()
|
|
((_ c ((a t) ...) more)
|
|
(letrec ((f (lambda (m ts)
|
|
(if (null? m)
|
|
""
|
|
(string-append (mk-cmd-arg* (car m) (caar ts) (cadar ts)) ;;; TODO -- Hier convert-arg-to-cmd in plotten, want dit worden symbols en dat is niet de bedoeling.
|
|
(f (cdr m) (cdr ts)))))))
|
|
(set! c (string-append c (f more (list '(a t) ...)))))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-syntax mk-cmd-call
|
|
(syntax-rules ()
|
|
((_ cmd type output-cvt)
|
|
(let ((r (ww-cmd cmd)))
|
|
(ww-debug (cmdr->list r))
|
|
(if (cmdr-ok r)
|
|
(output-cvt (convert-cmd-result-to type (cmdr-r r)))
|
|
'cmd-nok))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-syntax mk-func-def
|
|
(syntax-rules ()
|
|
((_ func cmd () () args type output-cvt)
|
|
(define (func)
|
|
(let ((c (format "~a" 'cmd)))
|
|
(mk-cmd-call c type output-cvt)))
|
|
)
|
|
((_ func cmd ((a t) ...) () args type output-cvt)
|
|
(define (func a ...)
|
|
(begin
|
|
(def-cmd-check a t)
|
|
...)
|
|
(let ((c (format "~a" 'cmd)))
|
|
(begin
|
|
(set! c (string-append c (mk-cmd-arg a t)))
|
|
...)
|
|
(mk-cmd-call c type output-cvt)
|
|
))
|
|
)
|
|
((_ func cmd () ((a t) ...) args type output-cvt)
|
|
(define (func . args)
|
|
(def-cmd-opt-checks ((a t) ...) args)
|
|
(let ((c (format "~a" 'cmd)))
|
|
(mk-cmd-opt-args c ((a t) ...) args)
|
|
(mk-cmd-call c type output-cvt)))
|
|
)
|
|
((_ func cmd ((a t ) ...) ((oa ot) ...) args type output-cvt)
|
|
(define (func a ... . args)
|
|
(begin
|
|
(def-cmd-check a t)
|
|
...)
|
|
(def-cmd-opt-checks ((oa ot) ...) args)
|
|
(let ((c (format "~a" 'cmd)))
|
|
(begin
|
|
(set! c (string-append c (mk-cmd-arg a t)))
|
|
...)
|
|
(mk-cmd-opt-args c ((oa ot) ...) args)
|
|
(mk-cmd-call c type output-cvt)))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-syntax id-converter
|
|
(syntax-rules ()
|
|
((_ val) val)))
|
|
|
|
(define-syntax def-cmd
|
|
(syntax-rules (args)
|
|
((_ func cmd mandatories optionals -> type)
|
|
(mk-func-def func cmd mandatories optionals args 'type id-converter))
|
|
((_ func cmd mandatories optionals -> type => output-converter)
|
|
(mk-func-def func cmd mandatories optionals args 'type output-converter))
|
|
)
|
|
)
|
|
|
|
(define-syntax def-func
|
|
(syntax-rules ()
|
|
((_ func () () args body)
|
|
(define (func)
|
|
body))
|
|
((_ func ((a t) ...) () args body)
|
|
(define (func a ...)
|
|
(begin
|
|
(def-cmd-check a t)
|
|
...)
|
|
(begin body)))
|
|
((_ func () ((oa ot) ...) args body)
|
|
(define (func . args)
|
|
(def-cmd-opt-checks ((oa ot) ...) args)
|
|
(begin body)))
|
|
((_ func ((a t) ...) ((oa ot) ...) args body)
|
|
(define (func a ... . args)
|
|
(begin
|
|
(def-cmd-check a t)
|
|
...)
|
|
(def-cmd-opt-checks ((oa ot) ...) args)
|
|
(begin body))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-syntax define/typed
|
|
(syntax-rules (args)
|
|
((_ (func mandatories optionals) body)
|
|
(def-func func mandatories optionals args body)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Web Wire Commands
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(def-cmd ww-log-level
|
|
loglevel () ((level symbol?)) -> symbol)
|
|
(def-cmd ww-protocol
|
|
protocol () () -> int)
|
|
|
|
;; Global stylesheet
|
|
(def-cmd ww-set-stylesheet
|
|
set-stylesheet ((st stylesheet-or-string?)) () -> void)
|
|
(def-cmd ww-get-stylesheet
|
|
get-stylesheet () () -> stylesheet)
|
|
|
|
;; New window
|
|
(def-cmd ww-new
|
|
new ((profile symbol?)) [(use-browser boolean?) (parent ww-win?)]
|
|
-> ww-win)
|
|
|
|
;; Close window
|
|
(def-cmd ww-close
|
|
close ((win-id ww-win?)) [] -> void)
|
|
|
|
;; Move window
|
|
(def-cmd ww-move
|
|
move ((win-id ww-win?) (x number?) (y number?)) [] -> void)
|
|
|
|
;; Resize window
|
|
(def-cmd ww-resize
|
|
resize ((win-id ww-win?) (width? number?) (height number?)) [] -> void)
|
|
|
|
;; Set title of window
|
|
(def-cmd ww-set-title
|
|
set-title ((win-id ww-win?) (title string?)) [] -> void)
|
|
|
|
;; Set icon of window
|
|
(def-cmd ww-set-icon
|
|
set-icon ((win-id ww-win?)
|
|
(svg-file (is-icon-file? 'svg))
|
|
(png-file (is-icon-file? 'png))) [] -> void)
|
|
|
|
;; Set menu of window
|
|
(def-cmd ww-set-menu
|
|
set-menu ((win-id ww-win?)
|
|
(menu is-menu?)) [] -> void)
|
|
|
|
|
|
(define (new-handle)
|
|
#t)
|
|
|
|
;; set url
|
|
(def-cmd ww-set-url
|
|
set-url ((win-id ww-win?)
|
|
(url string?)) () -> void)
|
|
|
|
;; Set html of window
|
|
(def-cmd ww-set-html
|
|
set-html ((win-id ww-win?)
|
|
(html-file html-file-exists?)) ()
|
|
-> number)
|
|
|
|
|
|
;; Set inner html of an Id of the HTML in the window
|
|
(def-cmd ww-set-inner-html
|
|
set-inner-html ((win-id ww-win?)
|
|
(html-of-file html-or-file?)) () -> void)
|
|
|
|
|
|
;; Het the inner html of an id of the HTML in the window
|
|
(def-cmd ww-get-inner-html
|
|
get-inner-html ((win-id ww-win?)
|
|
(element-id symbol-or-string?)) () -> json)
|
|
|
|
;; Set attribute of element in html
|
|
(def-cmd ww-set-attr
|
|
set-attr ((win-id ww-win?)
|
|
(element-id symbol-or-string?)
|
|
(attr symbol-or-string?)
|
|
(val any?)) () -> void)
|
|
|
|
;; Get attribute value of element in html
|
|
(def-cmd ww-get-attr
|
|
get-attr ((win-id ww-win?)
|
|
(element-id symbol-or-string?)
|
|
(attr symbol-or-string?)) () -> json)
|
|
|
|
;; Get all attributes of an element with given id
|
|
|
|
(define (mk-attrs r)
|
|
(let ((attrs (make-hash)))
|
|
(for-each (λ (attr-val)
|
|
(hash-set! attrs
|
|
(string->symbol (car attr-val))
|
|
(cadr attr-val)))
|
|
r)
|
|
attrs))
|
|
|
|
(def-cmd ww-get-attrs
|
|
get-attrs ((win-id ww-win?)
|
|
(element-id symbol-or-string?)) () -> json
|
|
-> mk-attrs)
|
|
|
|
;(define (ww-get-attrs w id)
|
|
; (let ((r (ww-get-attrs* w id)))
|
|
; (if (ww-cmd-nok? r)
|
|
; r
|
|
; (mk-attrs r))))
|
|
|
|
;; Get info of all elements for a selector
|
|
(def-cmd ww-get-elements
|
|
get-elements ((win-id ww-win?)
|
|
(selector selector?)) () -> json
|
|
-> (λ (r)
|
|
(map (λ (item)
|
|
(cons (string->symbol (car item))
|
|
(mk-attrs (cadr item))))
|
|
r)))
|
|
|
|
|
|
;(define (ww-get-elements win-id selector)
|
|
; (let ((r (ww-get-elements* win-id selector)))
|
|
; (map (λ (item)
|
|
; (cons (string->symbol (car item))
|
|
; (mk-attrs (cadr item))))
|
|
; r)))
|
|
|
|
;; Delete attribute of element
|
|
(def-cmd ww-del-attr
|
|
del-attr ((win-id ww-win?)
|
|
(element-id symbol-or-string?)
|
|
(attr symbol-or-string?)
|
|
) () -> void)
|
|
|
|
(define (ww-await . args)
|
|
#t)
|
|
|
|
;; get value of an element
|
|
(def-cmd ww-get-value
|
|
value ((win-id ww-win?)
|
|
(element-id symbol-or-string?)) () -> string)
|
|
|
|
;; set value of an element
|
|
(def-cmd ww-set-value
|
|
value ((win-id ww-win?)
|
|
(element-id symbol-or-string?)
|
|
(value any?)) () -> void)
|
|
|
|
;; Bind some CSS selector to an event, given that each
|
|
;; element that satisfies the selector has to have an id.
|
|
;; Note: get-elements, also working on selectors, will
|
|
;; assign an id to all elements that satisfy the selector
|
|
;; without one.
|
|
;; Returns list of lists of id, tag an type attribute of
|
|
;; each element that has been bound.
|
|
(def-cmd ww-bind
|
|
bind ((win-id ww-win?)
|
|
(event symbol-or-string?)
|
|
(selector selector?)) () -> json
|
|
-> (λ (r)
|
|
(map (λ (item)
|
|
(map string->symbol item))
|
|
r)))
|
|
|
|
;; Bind an element with the given id to the event
|
|
(def-cmd ww-on
|
|
on ((win-id ww-win?)
|
|
(event symbol-or-string?)
|
|
(id symbol-or-string?)) () -> void)
|
|
|
|
;; Element info
|
|
(def-cmd ww-element-info
|
|
element-info ((win-id ww-win?)
|
|
(element-id symbol-or-string?)) ()
|
|
-> json
|
|
-> (λ (r)
|
|
(list (string->symbol (car r))
|
|
(if (string=? (cadr r) "")
|
|
#f
|
|
(string->symbol (cadr r)))
|
|
(if (string=? (caddr r) "")
|
|
#f
|
|
(string->symbol (caddr r)))
|
|
(cadddr r)))
|
|
)
|
|
|
|
|
|
;; Add a class to an element
|
|
(def-cmd ww-add-class
|
|
add-class ((win-id ww-win?)
|
|
(element-id symbol-or-string?)
|
|
(class symbol-or-string?))
|
|
() -> void)
|
|
|
|
;; Remove a class from an element
|
|
(def-cmd ww-remove-class
|
|
remove-class ((win-id ww-win?)
|
|
(element-id symbol-or-string?)
|
|
(class symbol-or-string?))
|
|
() -> void)
|
|
|
|
;; Has a class
|
|
(define re-class-split #px"\\s+")
|
|
|
|
(define/typed (ww-has-class? ((win-id ww-win?)
|
|
(element-id symbol-or-string?)
|
|
(class* symbol-or-string?))
|
|
())
|
|
(let* ((cl (string-trim (ww-get-attr win-id element-id "class")))
|
|
(class (format "~a" class*)))
|
|
(if (eq? cl #f)
|
|
#f
|
|
(let* ((cls (regexp-split re-class-split cl)))
|
|
(letrec ((f (lambda (cls)
|
|
(if (null? cls)
|
|
#f
|
|
(let ((cl (car cls)))
|
|
(if (string=? cl class)
|
|
#t
|
|
(f (cdr cls))))
|
|
))
|
|
))
|
|
(f cls)))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Add a style to an element
|
|
(def-cmd ww-add-style
|
|
add-style ((win-id ww-win?)
|
|
(element-id symbol-or-string?)
|
|
(css-style css-style?)) () -> void)
|
|
|
|
;; Set a style of an element
|
|
(def-cmd ww-set-style
|
|
set-style ((win-id ww-win?)
|
|
(element-id symbol-or-string?)
|
|
(css-style css-style?)) () -> void)
|
|
|
|
;; Get the style of an element
|
|
(def-cmd ww-get-style
|
|
get-style ((win-id ww-win?)
|
|
(element-id symbol-or-string?)) ()
|
|
-> css-style)
|
|
|
|
;; Show State
|
|
(def-cmd ww-set-show-state
|
|
set-show-state ((win-id ww-win?)
|
|
(state symbol?)) ()
|
|
-> void)
|
|
|
|
(def-cmd ww-get-show-state
|
|
show-state ((win-id ww-win?)) ()
|
|
-> symbol)
|
|
|
|
;; Files and directories
|
|
(define (ww-file-open win-id title dir file-filters)
|
|
(let ((cmd (format "file-open ~a ~a ~a ~a" win-id
|
|
(as-string title)
|
|
(as-string dir)
|
|
(as-string file-filters))))
|
|
(ww-cmd cmd)))
|
|
|
|
(define (ww-file-save win-id title dir file-filters overwrite)
|
|
(let ((cmd (format "file-save ~a ~a ~a ~a ~a" win-id
|
|
(as-string title)
|
|
(as-string dir)
|
|
(as-string file-filters)
|
|
(if overwrite 1 0))))
|
|
(ww-cmd cmd)))
|
|
|
|
(define (ww-choose-dir win-id title dir)
|
|
(let ((cmd (format "choose-dir ~a ~a ~a" win-id
|
|
(as-string title)
|
|
(as-string dir))))
|
|
(ww-cmd cmd)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Finalizing stuff
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;(define will (make-will-executor))
|
|
|
|
;(define (ww-register-finalizer obj proc)
|
|
; (will-register will obj proc))
|
|
|
|
;(void (thread (λ () (let loop () (will-execute will) (loop)))))
|
|
|
|
); end of module |