racket-webview/private/js-transform.rkt

#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 " (format "~a" 'a) " = " (js1 b) ";\n")
     )
    )
  )

(define-syntax js2-let*
  (syntax-rules ()
    ((_ (a ...) b1 ...)
     (string-append "{\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 b2)
                      "; }\n"
                      )
     )
    )
  )


(define-syntax js-begin
  (syntax-rules ()
    ((_ a ...)
     (string-append "{\n"
                    (js a)
                    ...
                    " }\n"
                    )
     )
    )
  )
  

(define-syntax js-return
  (syntax-rules ()
    ((_ 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
      (js-dotcomma (js1 js-statement))
      ...
      )
     )
    )
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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))
                     )
                 )
               )
  )
|#