javascript generator syntax

main.rkt

@@ -10,6 +10,7 @@
 (require "rgba.rkt")
 (require "mimetypes.rkt")
 (require "menu.rkt")
+(require "private/js-transform.rkt")
 
 (provide (all-from-out "wv-context.rkt"
                        "wv-window.rkt"
@@ -21,6 +22,7 @@
                        "menu.rkt"
                        "racket-webview-downloader.rkt"
                        "racket-webview.rkt"
+                       "private/js-transform.rkt"
                        )
          webview-set-loglevel
          webview-version

private/js-transform.rkt

@@ -1,69 +1,390 @@
 #lang racket/base
 
+(require "utils.rkt"
+         (for-syntax racket/base)
+         (for-syntax racket/string)
+         (for-syntax "syntax-helpers.rkt")
+         (for-syntax "utils.rkt")
+         "syntax-helpers.rkt"
+         racket/string
+         )
+
+(provide js)
+
+(define-syntax js-infix
+  (syntax-rules ()
+    ((_ op (a ...))
+     (string-join (list (js1 a) ...) (format "~a~a " (if (eq? 'op '\,) "" " ") 'op)))
+    )
+  )
+
+
+(define-syntax (if-defined stx)
+  (syntax-case stx ()
+    [(_ id iftrue iffalse)
+     (let ([where (identifier-binding #'id)])
+       (if where #'iftrue #'iffalse))]))
+
+
+(define-syntax js-prim-1
+  (syntax-rules ()
+    ((_ a)
+     (symstr 'a))))
+
+(define-syntax (js-primitive stx)
+  (syntax-case stx ()
+    ((js-primitive a)
+     (cond
+       ((number? (syntax->datum #'a)) #'(format "~a" a))
+       ((string? (syntax->datum #'a)) #'(format "\"~a\"" (esc-double-quote (format "~a" a))))
+       ((identifier? #'a) #'(js-prim-1 a))
+       (else #'(js-prim-1 a)))
+     )
+    )
+  )
+
+
+(define-syntax js-func
+  (syntax-rules ()
+    ((_ f)
+     (format "~a()" 'f)
+     )
+    ((_ f a ...)
+     (string-append (format "~a(" 'f)
+                    (js-infix \, (a ...))
+                    ")")
+     )
+    )
+  )
+
+
+(define-syntax js-def
+  (syntax-rules ()
+    ((_ (f) (b ...))
+     (string-append
+      (format "function ~a()" 'f)
+      " {\n"
+      (js b ...)
+      "\n}\n"
+      ))
+    ((_ (f a1) (b ...))
+     (string-append
+      (format "function ~a(~a)" 'f 'a1)
+      " {\n"
+      (js b ...)
+      "\n}\n"))
+    ((_ (f a1 ...) (b ...))
+     (string-append
+      (string-append (format "function ~a(" 'f)
+                     (js-infix \, (a1 ...))
+                     ")")
+      " {\n"
+      (js b ...)
+      "\n}\n"))
+    ((_ a (b))
+     (format "~a = ~a;" 'a (js1 b))
+     )
+    )
+  )
+
+(define-syntax js-lambda
+  (syntax-rules ()
+    ((_ () a ...)
+     (string-append
+      "function () { "
+      (js a ...)
+      " }\n"
+      )
+     )
+    ((_ (a ...) b1 ...)
+     (string-append
+      (string-append
+       "function ("
+       (js-infix \, (a ...))
+       ")"
+       )
+      " { "
+      (js b1 ...)
+      " }\n")
+     )
+    )
+  )
+
+(define-syntax js-set
+  (syntax-rules ()
+    ((_ a b)
+     (string-append
+      (format "~a = " 'a)
+      (js1 b)
+      ";"
+      )
+     )
+    )
+  )
+
+(define-syntax js-send*
+  (syntax-rules ()
+    ((_ a b)
+     (format "~a.~a()" (js1 a) (js1 b)))
+    ((_ a b (a1))
+     (format "~a.~a(~a)" (js1 a) (js1 b) (js1 a1)))
+    ((_ a b (a1 a2 ...))
+     (format "~a.~a(~a)" (js1 a) (js1 b)
+             (js-infix \,  (a1 a2 ...))))
+    )
+  )
+
+(define-syntax js-send
+  (syntax-rules ()
+    ((_ (a b))
+     (js-send* a b))
+    ((_ (a b c ...))
+     (js-send* a b (c ...))
+     )
+    )
+  )
+
+(define (make-cons a b)
+  (format "(~a.unshift(~a),~a)" b a b))
+
+
+
 (define-syntax js-let
   (syntax-rules ()
     ((_ (a b))
-     (string-append "let " (js1 a) " = " (js1 b) ";\n")
+     (string-append "let " (format "~a" 'a) " = " (js1 b) ";\n")
      )
     )
   )
 
-(define-syntax js1
+(define-syntax js2-let*
-  (syntax-rules (if let* *)
+  (syntax-rules ()
-    ((_ (if cond body1 body2))
+    ((_ (a ...) b1 ...)
-     (string-append "if (" (js1 cond) ") then {\n"
+     (string-append "{\n"
-                    (js1 body1) "; }\n"
+                    (string-append (js-let a) ...)
+                    (js b1) 
+                    ...
+                    "\n}\n")
+     )
+    )
+  )
+
+(define-syntax js2-if
+  (syntax-rules ()
+    ((_ c b1 b2)
+     (string-append "if (" (js1 c) ") {\n"
+                      (js1 b1) "; }\n"
                       "else {\n"
-                    (js1 body2)
+                      (js1 b2)
                       "; }\n"
                       )
      )
-    ((_ (let (a ...)))
-     (string-append
-      (js-let a)
-      ...)
-     )
-    ((_ a)
-     (format "~a" 'a))
     )
   )
 
-#|
+
-    ((_ (if cond
+(define-syntax js-begin
-            body1
+  (syntax-rules ()
-            body2))
+    ((_ a ...)
-     (string-append "if ("
+     (string-append "{\n"
-                    (js1 cond) ") then {\n"
+                    (js a)
-                    (js1 body1) " }\n"
+                    ...
-                    "else { \n"
-                    (js1 body2)
                     " }\n"
                     )
      )
-    ((_ (let ((a b) ...)
-          body))
-     (string-append "let " (js1 a)
-                    " = " (js1 b) ";\n")
-     ...
     )
-    ((_ (* a b ...))
+  )
-     (string-append (js1 a) "*" (js1 b) ...))
+  
+
+(define-syntax js-return
+  (syntax-rules ()
     ((_ a)
-     (format "~a" 'a))
+     (string-append "return (" (js1 a) ");\n"))
     )
   )
-|#
+
+(define-syntax js-list
+  (syntax-rules ()
+    ((_ ())
+     (format "[ ]"))
+    ((_ (a ...))
+     (string-append "[ "
+                    (js-infix \, (a ...))
+                    "]")
+     )
+    )
+  )
+
+(define-syntax js-cons
+  (syntax-rules ()
+    ((_ (a b))
+     (format "~a.concat(~a)" (js-list (a)) (js1 b)))
+    )
+  )
+
+(define-syntax js-quote
+  (syntax-rules ()
+    ((_ (a ...))
+     (js-primitive (a ...)))
+    ((_ a)
+     (string-append "\"" (js-primitive a) "\"")
+     )
+    )
+  )
+
+
+(define-syntax (js-op stx)
+  (syntax-case stx ()
+    ((_ a . args)
+     (cond
+       ((eq? (syntax->datum #'a) '+) #'(js-infix + args))
+       ((eq? (syntax->datum #'a) '*) #'(js-infix * args))
+       ((eq? (syntax->datum #'a) '/) #'(js-infix / args))
+       ((eq? (syntax->datum #'a) '-) #'(js-infix - args))
+       ((eq? (syntax->datum #'a) 'and) #'(js-infix && args))
+       ((eq? (syntax->datum #'a) 'or) #'(js-infix || args))
+       ((eq? (syntax->datum #'a) 'send) #'(js-send args))
+       ((eq? (syntax->datum #'a) 'list) #'(js-list args))
+       ((eq? (syntax->datum #'a) 'cons) #'(js-cons args))
+       (else
+        #'(error (format "Not support by js-op: a = ~a" (syntax->datum #'a)))
+        )
+       )
+     )
+    )
+  )
+
+(define-for-syntax js-ops '(+ * / - and or send list cons))
+
+(define-syntax (js1 stx)
+  (syntax-case stx ()
+    ((_ (a c b1 b2))
+     (cond
+       ((eq? (syntax->datum #'a) 'if) #'(js2-if c b1 b2))
+       ((memq (syntax->datum #'a) js-ops) #'(js-op a c b1 b2))
+       ((eq? (syntax->datum #'a) 'let*) #'(js2-let* c b1 b2))
+       ((eq? (syntax->datum #'a) 'begin) #'(js-begin c b1 b2))
+       (else
+        ; could be a function call
+        #'(js-func a c b1 b2)
+        ;#'(error (format "Not supported by js macro (a c b1 b2), a = ~a" (syntax->datum #'a)))
+        )
+       )
+     )
+    ((_ (a b c))
+     (cond
+       ((eq? (syntax->datum #'a) '>) #'(js-infix > (b c)))
+       ((eq? (syntax->datum #'a) '<) #'(js-infix < (b c)))
+       ((eq? (syntax->datum #'a) '>=) #'(js-infix >= (b c)))
+       ((eq? (syntax->datum #'a) '<=) #'(js-infix <= (b c)))
+       ((eq? (syntax->datum #'a) '=) #'(js-infix = (b c)))
+       ((memq (syntax->datum #'a) js-ops) #'(js-op a b c))
+       ((eq? (syntax->datum #'a) 'define) #'(js-def b (c)))
+       ((eq? (syntax->datum #'a) 'lambda) #'(js-lambda b c))
+       ((eq? (syntax->datum #'a) 'λ) #'(js-lambda b c))
+       ((eq? (syntax->datum #'a) 'set!) #'(js-set b c))
+       ((eq? (syntax->datum #'a) 'let*) #'(js2-let* b c))
+       ((eq? (syntax->datum #'a) 'begin) #'(js-begin b c))
+       ((eq? (syntax->datum #'a) 'let) #'(error "let is not supported in js context, use let*"))
+       (else
+        ; could be a function call
+        #'(js-func a b c)
+        ;#'(error (format "Not supported by js macro (a b c), a = ~a" (syntax->datum #'a)))
+        )
+       )
+     )
+    ((_ (a b))
+     (cond
+       ((eq? (syntax->datum #'a) 'return) #'(js-return b))
+       ((eq? (syntax->datum #'a) 'quote) #'(js-quote b))
+       ;string-append
+       ;                                     "\"" (esc-double-quote (format "~a" 'b)) "\""))
+       (else
+        ; could be a function call
+        #'(js-func a b)
+        ;#'(error (format "Not supported by js macro (a b c), a = ~a" (syntax->datum #'a)))
+        )
+       )
+     )
+    ((_ (a c b1 ...))
+     (cond
+       ((eq? (syntax->datum #'a) 'let*) #'(js2-let* c b1 ...))
+       ((eq? (syntax->datum #'a) 'define) #'(js-def c (b1 ...)))
+       ((memq (syntax->datum #'a) js-ops) #'(js-op a c b1 ...))
+       ((eq? (syntax->datum #'a) 'begin) #'(js-begin c b1 ...))
+       ((eq? (syntax->datum #'a) 'let) #'(error "let is not supported in js context, use let*"))
+       ((eq? (syntax->datum #'a) 'js2-if) #'(error "Unexpected"))
+       (else
+        ; could be a function call
+        #'(js-func a c b1 ...)
+        ;#'(error (format "Not supported by js macro (a c b1 ...) a = ~a" (syntax->datum #'a)))
+        )
+       )
+     )
+    ((_ (a b ...))
+     (cond
+       ((memq (syntax->datum #'a) js-ops) #'(js-op a b ...))
+       (else
+        ; could be a function call
+        #'(js-func a b ...)
+        ;#'(error "Not supported by js macro (a b ...)"))
+        )
+       )
+     )
+    ((_ (a))
+     #'(js-func a)
+     )
+    ((_ a)
+     #'(js-primitive a)
+     )
+    )
+  )
+
+(define-syntax js-dotcomma
+  (syntax-rules ()
+    ((_ s)
+     (string-append s ";\n"))
+    )
+  )
+
 
 (define-syntax js
   (syntax-rules ()
     ((_ js-statement ...)
      (string-append
-      "{ \n"
+      (js-dotcomma (js1 js-statement))
-      (js1 js-statement)
       ...
-      "}\n"
       )
      )
     )
   )
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+#|
+(define t1
+  (js (set! window.myfunc (λ (x)
+                            (let* ((el (document.getElementById 'hi))
+                                   (y (* x x)))
+                              (el.setAttribute "x" (+ y ""))
+                              )
+                            )
+            )))
+
+(define t2 (js (define (f x)
+                 (if (and (> x 10) (< x 15))
+                     (begin (console.log x)
+                            (return x))
+                     (return (* x x))
+                     )
+                 )
+               )
+  )
+|#
+
+
+

private/syntax-helpers.rkt

@@ -0,0 +1,42 @@
+#lang racket/base
+
+(require racket/string
+         "utils.rkt"
+         )
+(provide symbol??
+         symstr
+         symstr-eval
+         is-if?)
+
+
+(define (symbol?? a)
+  (let ((r (symbol? a)))
+    r))
+
+(define (symstr x)
+  (cond
+    ((list? x)
+     (string-append "[ "
+                    (string-join (map symstr-eval x) ", ")
+                    " ]"))
+    ((vector? x)
+     (symstr (vector->list x)))
+    (else
+     (let ((r (format "~a" x)))
+       (let ((r* (if (string-prefix? r "(quote")
+                     (let ((s (substring r 7)))
+                       (substring s 0 (- (string-length s) 1)))
+                     r)))
+         r*)))
+    )
+  )
+
+
+(define (symstr-eval x)
+  (cond
+    ((string? x) (format "\"~a\"" (esc-double-quote x)))
+    (else (symstr x))))
+
+(define (is-if? x)
+  (displayln x)
+  (eq? x 'if))

racket-webview.rkt

@@ -720,8 +720,9 @@
 
 
 (define/contract (webview-call-js wv js)
-  (-> wv-win? string? (or/c string? list? boolean? hash? symbol?))
+  (-> wv-win? string? (or/c string? list? boolean? hash? symbol? number?))
   (let ((result (rkt-webview-call-js (wv-win-handle wv) js)))
+    ;(displayln result)
     (if (webview-call-js-result? result)
         (if (eq? (car result) 'oke)
             (hash-ref (fromJson (cadr result)) 'result #f)