From 8d00476ed296e3a43de28f5719d2d289d4436ad9 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Tue, 3 Mar 2026 16:42:10 +0100 Subject: [PATCH] - --- private/css.rkt | 211 +++++ private/menu.rkt | 178 ++++ .../racket-webview-ffi.rkt | 0 .../racket-webview-qt.rkt | 2 +- .../racket-webview.rkt | 26 +- private/utils.rkt | 64 ++ private/web-racket.rkt | 819 ++++++++++++++++++ utils.rkt | 22 - 8 files changed, 1289 insertions(+), 33 deletions(-) create mode 100644 private/css.rkt create mode 100644 private/menu.rkt rename racket-webview-ffi.rkt => private/racket-webview-ffi.rkt (100%) rename racket-webview-qt.rkt => private/racket-webview-qt.rkt (99%) rename racket-webview.rkt => private/racket-webview.rkt (89%) create mode 100644 private/utils.rkt create mode 100644 private/web-racket.rkt delete mode 100644 utils.rkt diff --git a/private/css.rkt b/private/css.rkt new file mode 100644 index 0000000..1c2d8ae --- /dev/null +++ b/private/css.rkt @@ -0,0 +1,211 @@ +(module css racket/base + + (require racket/string) + + (provide css-style + css-style->list + + set-css! + get-css + clear-css! + css-keys + + css-style? + + string->css-style + css-style->string + + stylesheet + stylesheet? + + stylesheet-set! + stylesheet-get + stylesheet-clear! + stylesheet-keys + + stylesheet->string + string->stylesheet + ) + + (define-struct style + ( + [style #:auto #:mutable] + ) + #:auto-value #f + #:transparent) + + (define-struct css-stylesheet + ( + [sheet #:auto #:mutable] + ) + #:auto-value (make-hashalw) + #:transparent) + + (define st-style style-style) + (define st-style! set-style-style!) + (define make-st make-style) + (define st? style?) + (define stylesheet? css-stylesheet?) + (define make-stylesheet make-css-stylesheet) + (define stylesheet-sheet css-stylesheet-sheet) + + + (define (css-style style_or_styles . args) + (if (symbol? style_or_styles) + (let ((css (if (null? args) "" (car args))) + (st (make-st))) + (st-style! st (make-hash)) + (hash-set! (st-style st) style_or_styles css) + st) + (let* ((st (make-st)) + (h (begin (st-style! st (make-hash)) (st-style st)))) + (for-each (lambda (st) + (let ((entry (car st)) + (css (cadr st))) + (hash-set! h entry (format "~a" css)))) + style_or_styles) + st))) + + (define (set-css! st entry css) + (hash-set! (st-style st) entry css) + st) + + (define (get-css st entry) + (hash-ref (st-style st) entry "")) + + (define (clear-css! st entry) + (hash-remove! (st-style st) entry)) + + (define (css-style? st) + (st? st)) + + (define (css-keys st) + (hash-keys (st-style st))) + + (define (css-style->list st) + (let* ((h (st-style st)) + (keys (hash-keys h))) + (map (lambda (k) + (list k (hash-ref h k))) + keys))) + + (define (css-style->string st . custom-sep) + (let* ((sep (if (null? custom-sep) " " (car custom-sep))) + (h (st-style st)) + (keys (hash-keys h))) + (letrec ((f (lambda (keys) + (if (null? keys) + "" + (let ((key (car keys))) + (string-append (symbol->string key) + ": " + (hash-ref h key) + ";" + sep + (f (cdr keys)))) + )) + )) + (string-trim (f keys))))) + + + (define re-style-split #px"\\s*[;]\\s*") + (define re-style-kv-split #px"\\s*[:]\\s*") + + (define (split-style-string style) + (let ((sp-style (regexp-split re-style-split style))) + (letrec ((f (lambda (entries) + (if (null? entries) + '() + (let* ((entry (string-trim (car entries))) + (kv (regexp-split re-style-kv-split entry)) + (key (car kv)) + (skey (if (string? key) + (string->symbol key) + key)) + (val (if (= (length kv) 2) (cadr kv) "")) + (keyval (list skey val)) + ) + (if (string=? entry "") + (f (cdr entries)) + (cons keyval (f (cdr entries))))) + )) + )) + (f sp-style)))) + + + + (define (string->css-style style-str) + (css-style (split-style-string style-str))) + + + (define (stylesheet entry_or_entries . style) + (if (symbol? entry_or_entries) + (let* ((st (car style)) + (ss (make-stylesheet)) + (h (stylesheet-sheet ss))) + (if (css-style? st) + (begin + (hash-set! h entry_or_entries st) + ss) + (error "A css-style is expected"))) + (let* ((ss (make-stylesheet)) + (h (stylesheet-sheet ss))) + (for-each (lambda (entry) + (let* ((key (car entry)) + (s (cadr entry))) + (if (css-style? s) + (hash-set! h key s) + (error (format "A css-style is expected for ~a" + key))) + )) + entry_or_entries) + ss))) + + (define (string->stylesheet str) + (error "Not implemented yet") + #t) + + (define (stylesheet-entry->string e) + (if (list? e) + (if (null? e) + "" + (string-append (stylesheet-entry->string (car e)) + " " + (stylesheet-entry->string (cdr e)))) + (format "~a" e))) + + (define (stylesheet->string ss) + (let* ((h (stylesheet-sheet ss)) + (keys (hash-keys h)) + (sep "\n")) + (letrec ((f (lambda (keys) + (if (null? keys) + "" + (let* ((key (car keys)) + (st (hash-ref h key))) + (string-append (stylesheet-entry->string key) " {\n " + (css-style->string st "\n ") + "\n}\n" + (f (cdr keys)))))) + )) + (f keys)))) + + (define (stylesheet-set! ss key style) + (let ((h (stylesheet-sheet ss))) + (hash-set! h key style) + ss)) + + (define (stylesheet-get ss key) + (let ((h (stylesheet-sheet ss))) + (hash-ref h key (make-st)))) + + (define (stylesheet-clear! ss key) + (let ((h (stylesheet-sheet ss))) + (hash-remove! h key))) + + (define (stylesheet-keys ss) + (let ((h (stylesheet-sheet ss))) + (hash-keys h))) + + + ); end of module \ No newline at end of file diff --git a/private/menu.rkt b/private/menu.rkt new file mode 100644 index 0000000..f36f55f --- /dev/null +++ b/private/menu.rkt @@ -0,0 +1,178 @@ +(module menu racket/base + + (require json) + + (provide menu + menu-item + is-menu? + menu-set-callback! + menu-set-icon! + menu-set-title! + menu->json + with-menu-item + menu-for-each + ww-menu-item-callback + ww-menu-item-id + ww-menu-id + ) + + + (define-struct ww-menu-item + (id [title #:mutable] [icon-file #:mutable] [callback #:mutable] [submenu #:mutable] [separator #:mutable]) + #:transparent) + + (define-struct ww-menu + (id [items #:mutable]) + #:transparent + ) + + (define (is-menu? mnu) + (if (ww-menu? mnu) + (if (list? (ww-menu-items mnu)) + (letrec ((f (lambda (m) + (if (null? m) + #t + (if (ww-menu-item? (car m)) + (if (eq? (ww-menu-item-submenu (car m)) #f) + (f (cdr m)) + (and (is-menu? (ww-menu-item-submenu (car m))) + (f (cdr m)))) + #f) + )) + )) + (f (ww-menu-items mnu))) + #f) + #f)) + + (define (menu . items) + (let ((menu-id #f)) + (when (symbol? (car items)) + (set! menu-id (car items)) + (set! items (cdr items))) + (when (list? (car items)) + (set! items (car items))) + (make-ww-menu menu-id items))) + + (define (menu-item id title + #:icon-file [icon-file #f] + #:callback [callback (lambda args #t)] + #:submenu [submenu #f] + #:separator [separator #f]) + (unless (symbol? id) + (error "menu-item needs an id of symbol?")) + (unless (string? title) + (error "menu-item needs a title of string?")) + (unless (or (eq? icon-file #f) (string? icon-file) (path? icon-file)) + (error "menu-item's optional argument icon-file must be #f, string? or path?")) + (unless (or (eq? submenu #f) (is-menu? submenu)) + (error "menu-item's optional argument submenu must be #f or is-menu?")) + (unless (boolean? separator) + (error "menu-item's optional argument separator must be boolean?")) + (make-ww-menu-item id title icon-file callback submenu separator)) + + (define (menu->hash menu . for-json) + (let ((fj (if (null? for-json) #f (car for-json)))) + (unless (is-menu? menu) + (error "menu->hash must be called with a menu")) + (let* ((items (ww-menu-items menu)) + (r (map (λ (item) + (let ((h (make-hasheq))) + (hash-set! h 'id (format "~a" (ww-menu-item-id item))) + (hash-set! h 'name (ww-menu-item-title item)) + (unless (eq? (ww-menu-item-icon-file item) #f) + (hash-set! h 'icon (ww-menu-item-icon-file item))) + (unless (eq? (ww-menu-item-submenu item) #f) + (hash-set! h 'submenu (menu->hash (ww-menu-item-submenu item) fj))) + (unless (eq? (ww-menu-item-separator item) #f) + (hash-set! h 'separator #t)) + h + )) items)) + ) + (let ((h (make-hasheq))) + (hash-set! h 'menu r) + (hash-set! h 'id (if fj (format "~a" (ww-menu-id menu)) (ww-menu-id menu))) + h)))) + + (define (menu-for-each menu cb) + (let ((items (ww-menu-items menu))) + (letrec ((f (λ (items) + (if (null? items) + #t + (let ((item (car items))) + (let ((submenu (ww-menu-item-submenu item))) + (if (eq? submenu #f) + (cb item) + (menu-for-each submenu cb))) + (f (cdr items)) + ) + ) + ) + )) + (f items)))) + + (define (menu->json menu) + (let ((o (open-output-string))) + (write-json (menu->hash menu #t) o) + (get-output-string o))) + + (define (find-menu-item menu id) + (let ((items (ww-menu-items menu))) + (letrec ((f (λ (items) + (if (null? items) + #f + (let ((item (car items))) + (if (eq? (ww-menu-item-id item) id) + item + (let ((submenu (ww-menu-item-submenu item))) + (if (eq? submenu #f) + (f (cdr items)) + (let ((found-item (find-menu-item submenu id))) + (if (eq? found-item #f) + (f (cdr items)) + found-item)) + )) + )) + )) + )) + (f items)))) + + (define (with-menu-item menu id cb) + (unless (is-menu? menu) + (error "menu must be of is-menu?")) + (unless (symbol? id) + (error "id must be of symbol?")) + (let ((item (find-menu-item menu id))) + (if (eq? item #f) + (error (format "cannot find id'~a in given menu" id)) + (cb item))) + menu) + + (define (menu-set-title! menu id title) + (unless (string? title) + (error "title must be of string?")) + (with-menu-item menu id + (λ (item) + (set-ww-menu-item-title! item title)))) + + (define (menu-set-icon! menu id icon) + (unless (or (eq? icon #f) (path? icon) (string? icon)) + (error "title must be of #f, string? or path?")) + (with-menu-item menu id + (λ (item) + (set-ww-menu-item-icon-file! item icon)))) + + (define (menu-set-callback! menu id cb) + (unless (procedure? cb) + (error "callback must be of procedure?")) + (with-menu-item menu id + (λ (item) + (set-ww-menu-item-callback! item cb)))) + + ); end of module + + + + + + + \ No newline at end of file diff --git a/racket-webview-ffi.rkt b/private/racket-webview-ffi.rkt similarity index 100% rename from racket-webview-ffi.rkt rename to private/racket-webview-ffi.rkt diff --git a/racket-webview-qt.rkt b/private/racket-webview-qt.rkt similarity index 99% rename from racket-webview-qt.rkt rename to private/racket-webview-qt.rkt index bb13019..053b7a7 100644 --- a/racket-webview-qt.rkt +++ b/private/racket-webview-qt.rkt @@ -34,7 +34,7 @@ (define lib-type 'release) -(define-runtime-path lib-dir "lib") +(define-runtime-path lib-dir "../lib") (define libname (let ((os (system-type 'os*))) (cond ((eq? os 'windows) (format "rktwebview.dll")) diff --git a/racket-webview.rkt b/private/racket-webview.rkt similarity index 89% rename from racket-webview.rkt rename to private/racket-webview.rkt index db838d0..e7d301e 100644 --- a/racket-webview.rkt +++ b/private/racket-webview.rkt @@ -21,6 +21,7 @@ webview-move webview-resize webview-bind! + webview-standard-file-getter ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -30,7 +31,7 @@ (define current-servlet-port 8083) (define current-window-nr 1) -(define-runtime-path js-path "js") +(define-runtime-path js-path "../js") (define (default-boilerplate-js) (let ((file (build-path js-path "boilerplate.js"))) @@ -153,6 +154,18 @@ (define (webview-run-js wv js) (rkt-webview-run-js (wv-handle wv) js)) +(define (webview-standard-file-getter base-path + #:not-exist [on-not-exist (λ (file base-path path) path)] + ) + (λ (file) + (let ((f (if (string=? file "/") "index.html" file))) + (when (string-prefix? f "/") + (set! f (substring f 1))) + (let ((p (build-path base-path f))) + (if (not (file-exists? p)) + (on-not-exist file base-path p) + p))))) + ;(define (webview-call-js wv js) ; (let ((result (rkt_webview_call_js (wv-handle wv) js))) ; result)) @@ -161,16 +174,9 @@ ;; testing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-runtime-path example-path "example") +(define-runtime-path example-path "../example") -(define (file-getter file) - (displayln (format "file-getter: ~a" file)) - (let ((f (if (string=? file "/") "index.html" file))) - (when (string-prefix? f "/") - (set! f (substring f 1))) - (let ((p (build-path example-path f))) - (displayln p) - p))) +(define file-getter (webview-standard-file-getter example-path)) (define (test) (let* ((cb (λ (handle evt) diff --git a/private/utils.rkt b/private/utils.rkt new file mode 100644 index 0000000..a786b97 --- /dev/null +++ b/private/utils.rkt @@ -0,0 +1,64 @@ +#lang racket/base + + +(provide while + until + get-lib-path + do-for + ) + +(define-syntax while +(syntax-rules () + ((_ cond body ...) + (letrec ((while-f (lambda (last-result) + (if cond + (let ((last-result (begin + body + ...))) + (while-f last-result)) + last-result)))) + (while-f #f)) + ) + )) + +(define-syntax until +(syntax-rules () + ((_ cond body ...) + (letrec ((until-f (lambda (last-result) + (if cond + last-result + (let ((last-reult (begin + body + ...))) + (until-f last-result)))))) + (until-f #f))))) + +(define-syntax do-for +(syntax-rules () + ((_ (init cond next) body ...) + (begin + init + (letrec ((do-for-f (lamba () + (if cond + (begin + (begin + body + ...) + next + (do-for-f)))))) + (do-for-f)))))) + +(define (get-lib-path lib) +(let ((platform (system-type))) + (cond + [(eq? platform 'windows) + (let ((try1 (build-path (current-directory) ".." "lib" "dll" lib)) + (try2 (build-path (current-directory) "lib" "dll" lib))) + (if (file-exists? try1) + try1 + try2) + )] + [else + (error (format "Install the shared library: ~a" lib))] + ))) + diff --git a/private/web-racket.rkt b/private/web-racket.rkt new file mode 100644 index 0000000..64484a8 --- /dev/null +++ b/private/web-racket.rkt @@ -0,0 +1,819 @@ +(module web-racket racket/gui + + (require racket/gui + "racket-webview.rkt" + "css.rkt" + "menu.rkt" + racket-sprintf + ;"webui-wire-download.rkt" + "utils.rkt" + html-printer + (prefix-in g: gregor) + (prefix-in g: gregor/time) + gregor-utils + net/sendurl + racket/path + xml + ) + + (provide ww-element% + + ww-input% + ww-input-email% + ww-input-date% + ww-input-time% + ww-input-datetime% + ww-input-range% + + ww-webview% + ww-webview-dialog% + ww-settings% + ww-webview-message% + + ww-start + ww-stop + ww-set-debug + ww-debug + ww-error + ww-set-log-level + ww-log-level + ww-exec-js + + (all-from-out "css.rkt") + (all-from-out "menu.rkt") + + ww-set-custom-webui-wire-command! + ww-get-webui-wire-version + ww-display-log + ww-tail-log + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Regexes + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define re-resize #px"([0-9]+)\\s+([0-9]+)") + (define re-move re-resize) + (define re-file-open #px"([0-9]+)[:]([^:]+)[:](.*)") + (define re-choose-dir re-file-open) + (define re-navigate #px"(.*)[:]([^:]+)[:]([^:]+)$") + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; GUI classes + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define _std_x 100) + (define _std_y 100) + (define _std_w 800) + (define _std_h 600) + + (define (next-window-init-position) + (set! _std_x (+ _std_x 75)) + (set! _std_y (+ _std_y 50)) + (call-with-values + get-display-size + (lambda (w h) + (when (> (+ _std_y _std_h) h) + (set! _std_y 50)) + (when (> (+ _std_x _std_w) w) + (set! _std_x 50)) + ))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Class representing an element in the HTML page + ;; each element is identified by an id. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define ww-element% + (class object% + (init-field [win-id #f] [id #f]) + + (define/public (get-win-id) + win-id) + + (define/public (get-id) + id) + + (define/public (win) + (let ((w (hash-ref windows (ww-win-id win-id) #f))) + w)) + + (define connected-callbacks (make-hash)) + + (define/public (callback evt . args) + (ww-debug (format "WW-ELEMENT%: Callback for ~a - ~a - ~a" id evt args)) + (let ((cb (hash-ref connected-callbacks evt #f))) + (unless (eq? cb #f) + (with-handlers ([exn:fail? + (λ (e) + (ww-error (format "callback for ~a: ~a" evt e)))]) + (apply cb args))))) + + (define/public (exec-js js) + (ww-exec-js win-id js)) + + (define/public (connect evt func) + (hash-set! connected-callbacks evt func)) + + (define/public (disconnect evt) + (hash-remove! connected-callbacks evt)) + + (define/public (add-style! st) + (ww-add-style win-id id st)) + + (define/public (set-style! st) + (ww-set-style win-id id st)) + + (define/public (style) + (ww-get-style win-id id)) + + (define/public (get-attr a) + (ww-get-attr win-id id a)) + + (define/public (set-attr! a val) + (ww-set-attr win-id id a val)) + + (define/public (del-attr a) + (ww-del-attr win-id id a)) + + (define/public (get-attrs) + (ww-get-attrs win-id id)) + + (define/public (add-class! cl) + (ww-add-class win-id id cl)) + + (define/public (remove-class! cl) + (ww-remove-class win-id id cl)) + + (define/public (has-class? cl) + (ww-has-class? win-id id cl)) + + (define/public (enable) + (send this remove-class! 'disabled)) + + (define/public (enabled?) + (not (send this disabled?))) + + (define/public (disable) + (send this add-class! 'disabled)) + + (define/public (disabled?) + (send this has-class? 'disabled)) + + (define/public (display . args) + (let ((d (if (null? args) "block" (car args)))) + (send this add-style! (css-style 'display d)))) + + (define/public (hide) + (send this display "none")) + + (define/public (show) + (send this display "block")) + + (define/public (show-inline) + (send this display "inline-block")) + + (define/public (set-inner-html! html-or-sexpr) + (if (string? html-or-sexpr) + (ww-set-inner-html win-id id html-or-sexpr) + (set-inner-html! (xexpr->html5 html-or-sexpr)))) + + (super-new) + ) + ) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Classes representing different kinds of input/textarea elements in html + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define-syntax inp-set! + (syntax-rules () + ((_ var val) + (set! var val)))) + + + ;;;; Generic input + (define ww-input% + (class ww-element% + + (define cb #f) + (define val #f) + + (define/public (value-converter v) + v) + + (define/public (get) + val) + + (define/public (on-change! callback) + (inp-set! cb callback) + (cb val) + ) + + (define/public (set! v) + (inp-set! val v) + (ww-set-value (send this get-win-id) + (send this get-id) v)) + + (define/override (disable) + (super disable) + (ww-set-attr (send this get-win-id) + (send this get-id) 'disabled "")) + + (define/override (enable) + (super enable) + (ww-del-attr (send this get-win-id) + (send this get-id) 'disabled)) + + (super-new) + + (begin + + (let ((v (ww-get-value (send this get-win-id) (send this get-id)))) + (inp-set! val (send this value-converter v))) + + (send this connect 'input (λ (data) + (ww-debug "WW-INPUT% 'input event:" data) + (let ((js-evt (hash-ref data 'js_evt #f))) + (ww-debug "WW-INPUT% 'input event, js-evt = " js-evt) + (unless (eq? js-evt #f) + (when (hash-has-key? js-evt 'value) + (let ((v (hash-ref js-evt 'value))) + (inp-set! val v) + (unless (eq? cb #f) + (cb v)) + )))) + )) + (send (send this win) bind 'input (format "#~a" (send this get-id))) + ) + )) + + + ;;;; Email input + (define ww-input-email% + (class ww-input% + + (super-new))) + + ;;;; Date input + (define ww-input-date% + (class ww-input% + + (define/override (get) + (let ((val (super get))) + (g:parse-date val "yyyy-MM-dd"))) + + (define/override (set! d) + (when (racket-date? d) + (set! (date->moment d))) + (unless (or (g:date? d) (g:moment? d) (g:datetime? d)) + (error "set! - gregor date expected")) + (super set! (sprintf "%04d-%02d-%02d" (g:->year d) (g:->month d) (g:->day d))) + d) + + (super-new) + )) + + ;;;; Time input + (define ww-input-time% + (class ww-input% + + (define/override (get) + (let ((val (super get))) + (with-handlers ([exn:fail? + (λ (e) (g:parse-time val "HH:mm"))]) + (g:parse-time val "HH:mm:ss")))) + + (define/override (set! t) + (when (racket-date? t) + (set! (date->moment t))) + (unless (or (g:time? t) (g:datetime? t) (g:moment? t)) + (error "set! - gregor time?, moment? or datetime? expected")) + (super set! (sprintf "%02d:%02d:%02d" (g:->hours t) (g:->minutes t) (g:->seconds t)))) + + (super-new) + )) + + ;;;;; Date-time local + (define ww-input-datetime% + (class ww-input% + + (define/override (get) + (let ((val (super get))) + (with-handlers ([exn:fail? + (λ (e) (g:parse-moment val "yyyy-MM-dd'T'HH:mm:ss"))]) + (g:parse-moment val "yyyy-MM-dd'T'HH:mm")))) + + (define/override (set! m) + (when (racket-date? m) + (set! date->moment m)) + (unless (or (g:datetime? m) (g:moment? m) (g:date? m) (g:time? m)) + (error "set! - gregor time? , date?, datetime? or moment? expected")) + #t) + + (super-new) + ) + ) + + ;;;; Range + (define ww-input-range% + (class ww-input% + + (define/override (value-converter v) + (string->number v)) + + (super-new) + )) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Classes representing WebView Windows. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define ww-webview% + (class object% + + (init-field [profile 'default-profile] + [settings #f] + [use-browser #f] + [parent-id #f] + [parent #f] + [title "Racket HTML Window"] + [x (if (eq? settings #f) _std_x (send settings get 'window-x _std_x))] + [y (if (eq? settings #f) _std_y (send settings get 'window-y _std_y))] + [width (if (eq? settings #f) _std_w (send settings get 'window-width _std_w))] + [height (if (eq? settings #f) _std_h (send settings get 'window-height _std_h))] + [icon #f] + [menu #f] + [html-file #f] + ) + + (define win-id #f) + + (define menu-cbs (make-hash)) + (define elements (make-hash)) + (define html-handle #f) + + (define/public (clone-settings section) + (if (eq? settings #f) + #f + (send settings clone section))) + + (define (event-handler content) + (let ((evt (hash-ref content 'event #f))) + (ww-debug (format "win-id=~a '~a ~a" win-id evt content)) + (cond + ([eq? evt 'page-loaded] (let ((page-handle (hash-ref content 'page_handle 'none))) + (ww-debug (format "html-handle: ~a, page-handle: ~a, equal?: ~a" + html-handle + page-handle + (equal? html-handle page-handle))) + (when (and (number? html-handle) (number? page-handle) (= html-handle page-handle)) + (send this html-loaded)))) + ([eq? evt 'click] (handle-click (string->symbol (hash-ref content 'id)) content)) + ([eq? evt 'dblclick] (handle-dblclick (string->symbol (hash-ref content 'id)) content)) + ([eq? evt 'contextmenu] (handle-contextmenu (string->symbol (hash-ref content 'id)) content)) + ([eq? evt 'input] (handle-input (string->symbol (hash-ref content 'id)) content)) + ([eq? evt 'change] (handle-change (string->symbol (hash-ref content 'id)) content)) + ([eq? evt 'resized] (let* ((width* (hash-ref content 'width)) + (height* (hash-ref content 'height)) + ) + (set! width width*) + (set! height height*) + (unless (eq? settings #f) + (send settings set 'window-width width) + (send settings set 'window-height height)) + )) + ([eq? evt 'moved] (let* ((x* (hash-ref content 'x)) + (y* (hash-ref content 'y)) + ) + (set! x x*) + (set! y y*) + (unless (eq? settings #f) + (send settings set 'window-x x) + (send settings set 'window-y y)) + )) + ([eq? evt 'close-request] (when (send this can-close?) + (send this close))) + ([eq? evt 'menu-item-choosen] (let* ((menu-id (string->symbol (hash-ref content 'item))) + (cb (hash-ref menu-cbs menu-id #f))) + (unless (eq? cb #f) + (cb)))) + ([eq? evt 'navigate] (let* ((url (hash-ref content 'url)) + (kind (string->symbol (hash-ref content + 'navigation-kind))) + (type (string->symbol (hash-ref content + 'navigation-type))) + ) + (send this handle-navigate url type kind))) + ([eq? evt 'choose-dir] (let* ((handle (hash-ref content 'handle)) + (choosen (hash-ref content 'choosen)) + (dir (hash-ref content 'dir)) + ) + (send this dir-choosen handle choosen dir))) + ([eq? evt 'inner-html-set] (let* ((handle (hash-ref content 'handle)) + (has-been-set (hash-ref content 'oke))) + (send this inner-html-set handle has-been-set))) + ) + ) + ) + + (define/public (handle-click element-id data) + (let ((el (hash-ref elements element-id #f))) + (unless (eq? el #f) + (send el callback 'click data)))) + + (define/public (handle-dblclick element-id data) + (let ((el (hash-ref elements element-id #f))) + (unless (eq? el #f) + (send el callback 'dblclick data)))) + + (define/public (handle-contextmenu element-id data) + (let ((el (hash-ref elements element-id #f))) + (unless (eq? el #f) + (send el callback 'contextmenu data)))) + + (define/public (handle-change element-id data) + (let ((el (hash-ref elements element-id #f))) + (unless (eq? el #f) + (send el callback 'change data 'value)))) + + (define/public (handle-input element-id data) + (let ((el (hash-ref elements element-id #f))) + (unless (eq? el #f) + (send el callback 'input data)))) + + (define/public (handle-navigate url type kind) + (let ((method (if (eq? kind 'set-html) 'set-html-file! 'set-url))) + (cond + ([eq? type 'standard] + (dynamic-send this method url)) + (else (ww-error (format "Don't know what to do for ~a - ~a" type url))) + ) + ) + ) + + (define/public (get-win-id) win-id) + + (define/public (exec-js js) + (ww-exec-js win-id js)) + + (define (cl-selector tag type) + (cond + ([eq? tag 'INPUT] + (cond + ([eq? type 'text] ww-input%) + ([eq? type 'date] ww-input-date%) + ([eq? type 'datetime-local] ww-input-datetime%) + ([eq? type 'range] ww-input-range%) + (else ww-input%))) + (else ww-element%))) + + (define/public (bind event selector . forced-cl) + (ww-debug (format "call to bind ~a ~a ~a" event selector forced-cl)) + (let ((infos (ww-bind win-id event selector))) + (for-each (λ (info) + (let* ((id (car info)) + (tag (cadr info)) + (type (caddr info))) + (ww-debug (format "bind: ~a ~a ~a" id tag type)) + (let ((cl (if (null? forced-cl) + (cl-selector tag type) + (car forced-cl)))) + (unless (hash-has-key? elements id) + (hash-set! elements id 'in-the-making) + (hash-set! elements id + (new cl [win-id win-id] [id id])))))) + infos))) + + (define/public (bind-inputs) + (bind 'change 'input ) + (bind 'change 'textarea) + #t + ) + + (define/public (bind-buttons) + (bind 'click 'button) + ) + + (define/public (element id) + (unless (hash-has-key? elements id) + (let ((info (ww-element-info win-id id))) + (let* ((el-id (car info)) + (tag (cadr info)) + (type (caddr info)) + (exist (cadddr info)) + ) + (unless exist + (ww-debug (format "Element ~a does not exist!" id))) + (let* ((cl (cl-selector tag type)) + (obj (new cl [win-id win-id] [id id]))) + (hash-set! elements el-id obj) + )) + (element id)) + ) + (hash-ref elements id)) + + (define/public (new-element id . cl-selector) + (unless (hash-has-key? elements id) + (let ((cl (if (null? cl-selector) ww-element% (car cl-selector)))) + (let ((obj (new cl [win-id win-id] [id id]))) + (hash-set! elements id obj)))) + (hash-ref elements id)) + + (define/public (get-elements selector) + (ww-get-elements win-id selector)) + + (define/public (move x y) + (ww-move win-id x y)) + + (define/public (resize x y) + (ww-resize win-id x y)) + + (define/public (get-x) x) + (define/public (get-y) y) + (define/public (get-width) width) + (define/public (get-height) height) + (define/public (geom) (list x y width height)) + + (define/public (set-title! t) + (set! title t) + (ww-set-title win-id t)) + + (define/public (get-title) + title) + + (define/public (set-icon! icn) + (ww-set-icon win-id icn)) + + (define/public (set-html-file! file) + (let* ((full-path (if (string? file) + (string->path file) + file)) + (folder (path-only full-path)) + (the-file (file-name-from-path full-path)) + ) + (ww-debug (format "set-html-file! ~a, ~a" folder the-file)) + (set! html-file file) + (when folder + (ww-cwd folder)) + (set! html-handle (ww-set-html-file win-id the-file)) + (ww-debug (format "html file set to ~a" the-file)) + )) + + (define/public (set-html html) + (let* ((tmpfile "/tmp/test.html") + (fh (open-output-file tmpfile #:exists 'replace))) + ;(displayln tmpfile) + (display html fh) + (close-output-port fh) + (send this set-html-file! tmpfile) + ) + ) + + (define/public (set-url url) + (send-url url)) + + (define/public (html-loaded) + (send this bind-buttons) + (send this bind-inputs)) + + (define/public (get-html-file) + html-file) + + (define/public (show) + (ww-set-show-state win-id 'show)) + + (define/public (hide) + (ww-set-show-state win-id 'hide)) + + (define/public (maximize) + (ww-set-show-state win-id 'maximize)) + + (define/public (normalize) + (ww-set-show-state win-id 'normalize)) + + (define/public (minimize) + (ww-set-show-state win-id 'minimize)) + + (define/public (fullscreen) + (ww-set-show-state win-id 'fullscreen)) + + (define/public (show-state) + (ww-get-show-state win-id)) + + (define/public (can-close?) + #t) + + (define/public (close) + (ww-close win-id) + (hash-remove! windows (ww-win-id win-id)) + (hash-remove! windows-evt-handlers (ww-win-id win-id)) + (when (= (hash-count windows) 0) + (ww-stop)) + ) + + (define/public (set-menu! menu-def) + (ww-set-menu win-id menu-def)) + + (define/public (connect-menu! id cb) + (hash-set! menu-cbs id cb)) + + (define/public (disconnect-menu! id) + (hash-remove! menu-cbs id) + ) + + (define/public (popup-menu menu-def x y) + (ww-popup-menu win-id menu-def x y) + (let* ((ids (list)) + (clear-connections (λ () + (for-each (λ (id) + (send this disconnect-menu! id)) + ids)))) + (menu-for-each menu-def + (λ (item) + (let ((cb (ww-menu-item-callback item)) + (id (ww-menu-item-id item))) + (set! ids (cons id ids)) + (send this connect-menu! id (λ () + (clear-connections) + (cb)))))) + (connect-menu! (ww-menu-id menu-def) (λ () (clear-connections))) + (set! ids (cons (ww-menu-id menu-def) ids)) + ) + ) + + ; files and directories + (define/public (file-open caption base-dir filters) + (let ((r (ww-file-open win-id caption base-dir filters))) + (if (eq? (car r) #f) + #f + (let ((m (regexp-match re-file-open (cdr r)))) + (if (eq? m #f) + #f + (let ((file (cadddr m))) + (ww-from-string file)) + ) + ) + ) + ) + ) + + (define/public (file-save caption base-dir filters . overwrite) + (let ((o (if (null? overwrite) #f (car overwrite)))) + (let ((r (ww-file-save win-id caption base-dir filters o))) + (if (eq? (car r) #f) + #f + (let ((m (regexp-match re-file-open (cdr r)))) + (if (eq? m #f) + #f + (let ((file (cadddr m))) + (ww-from-string file)) + ) + ) + ) + ) + ) + ) + + (define/public (choose-dir caption base-dir) + (let ((bdir (string-trim base-dir))) + (when (or (string=? bdir "") (string=? bdir ".") (string=? bdir "..")) + (set! bdir (path->string (find-system-path 'home-dir)))) + (while (and (> (string-length bdir) 0) + (or (string-suffix? bdir "\\") (string-suffix? bdir "/"))) + (set! bdir (substring bdir 0 (- (string-length bdir) 1))) + ) + (when (string=? bdir "") + (set! bdir (path->string (find-system-path 'home-dir)))) + (when (or (string-suffix? bdir "\\") (string-suffix? bdir "/")) + (set! bdir (substring bdir 0 (- (string-length bdir) 1)))) + (ww-debug (format "ww-choose-dir ~a ~a ~a" win-id caption bdir)) + (let ((r (ww-choose-dir win-id caption bdir))) + (ww-debug (format "choose-dir: ~a" r)) + (if (eq? r 'cmd-nok) + #f + r)))) + + (define/public (dir-choosen handle choosen dir) + (ww-debug (format "dir-choosen: handle=~a, choosen=~a, dir=~a" handle choosen dir)) + ) + + (define/public (inner-html-set handle oke) + (ww-debug (format "inner-html-set ~a: ~a" handle oke)) + ) + + (define/public (inherit-checks) + #t) + + ; Supers first + (super-new) + + ; construct + (begin + (send this inherit-checks) + + ;(when (= (hash-count windows) 0) + ; (ww-start)) + + ;(when (eq? parent-id #f) + ; (unless (eq? parent #f) + ; (set! parent-id (send parent get-win-id)))) + + ;(when (eq? parent #f) + ; (unless (eq? parent-id #f) + ; (set! parent (ww-get-window-for-id parent-id)))) + + (next-window-init-position) + + ;(set! win-id + ; (if (eq? parent-id #f) + ; (ww-new profile use-browser) + ; (ww-new profile use-browser parent-id))) + (set! win-id (webview-create + (λ (file) file) + (when (eq? win-id #f) + (error "Window could not be constructed")) + + (hash-set! windows-evt-handlers (ww-win-id win-id) event-handler) + (hash-set! windows (ww-win-id win-id) this) + + (ww-resize win-id width height) + + (when parent + (let* ((parent-width (send parent get-width)) + (parent-height (send parent get-height)) + (parent-x (send parent get-x)) + (parent-y (send parent get-y)) + ) + (set! x (+ parent-x (/ (- parent-width width) 2))) + (set! y (+ parent-y (/ (- parent-height height) 2))) + ) + ) + (ww-move win-id x y) + + (send this set-title! title) + + (unless (eq? icon #f) + (send this set-icon! icon)) + + (unless (eq? menu #f) + (send this set-menu! menu)) + + (unless (eq? html-file #f) + (send this set-html-file! html-file)) + ) + + )) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Classes representing WebView Dialogs + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define ww-webview-dialog% + (class ww-webview% + (super-new) + + (inherit-field parent) + + (define/override (inherit-checks) + (when (eq? parent #f) + (error "A parent must be given"))) + )) + + + (define ww-webview-message% + (class ww-webview-dialog% + (super-new) + + (send this set-html + "Message

[msg]

[submsg]

" + ) + ) + ) + + (define (set-global-stylesheet st) + (ww-set-stylesheet st)) + + (define (get-global-stylesheet) + (ww-get-stylesheet)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Classes for settings + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define ww-settings% + (class object% + (super-new) + (define/public (set key value) + (error "ww-settings%: set not implemented, override in your specific subclass")) + (define/public (get key . default) + (error "ww-settings%: get not implemented, override in your specific subclass")) + (define/public (clone new-section) + (error "ww-settings%: clone not implemented, override in your specific subclass")) + (define/public (set! key value) + (send this set key value)) + ) + ) + + ); end of module diff --git a/utils.rkt b/utils.rkt deleted file mode 100644 index 00679f5..0000000 --- a/utils.rkt +++ /dev/null @@ -1,22 +0,0 @@ -#lang racket/base - -(provide while) - -(define-syntax while - (syntax-rules () - ((_ cond - body ...) - (letrec ((while (λ () - (if cond - (begin - (displayln "cond = true") - (begin body ...) - (while)) - (begin - (displayln "cond = false") - 'done))) - )) - (while))) - ) - ) - \ No newline at end of file