#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 (make-eval-result v) (cond ((or (symbol? v) (string? v)) (format "\"~a\"" (esc-double-quote (format "~a" v)))) ((list? v) (string-append "[ " (string-join (map make-eval-result v) ", ") " ]")) ((number? v) (format "~a" v)) (else (error "Not supported result by js-eval, supported: string, symbol, number or list of previous") ) ) ) (define-syntax js-eval (syntax-rules () ((_ v) (make-eval-result v)))) (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))) ((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)) ((eq? (syntax->datum #'a) 'eval) #'(js-eval 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)) ) ) ) ) |#