diff --git a/.gitignore b/.gitignore index 39a4f9c..3bd7ab8 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,4 @@ compiled/ # Dependency tracking files *.dep +/*.bak diff --git a/main.rkt b/main.rkt index e826666..7e47898 100644 --- a/main.rkt +++ b/main.rkt @@ -1,1460 +1,335 @@ #lang racket/base (require racket/string - (for-syntax racket/base - racket/list - racket/match - racket/string)) - -(provide js js/expression) - -;; Convert a Racket value produced by (inject ) or the -;; historical alias (eval ) inside a js form to a JavaScript -;; literal string. This is a Racket -> JavaScript interpolation boundary, -;; not JavaScript eval. -(define (jsmaker-runtime-escape-js-string s) - (define out (open-output-string)) - (for ([ch (in-string s)]) - (case ch - [(#\\) (display "\\\\" out)] - [(#\") (display "\\\"" out)] - [(#\newline) (display "\\n" out)] - [(#\return) (display "\\r" out)] - [(#\tab) (display "\\t" out)] - [else (display ch out)])) - (get-output-string out)) - -(define (jsmaker-runtime-js-string s) - (format "\"~a\"" (jsmaker-runtime-escape-js-string s))) - -(define (jsmaker-runtime-key->js k) - (jsmaker-runtime-js-string - (cond [(symbol? k) (symbol->string k)] - [(keyword? k) (keyword->string k)] - [(string? k) k] - [else (format "~a" k)]))) - -(define (jsmaker-runtime-value->js v) - (cond - [(void? v) "undefined"] - [(eq? v #t) "true"] - [(eq? v #f) "false"] - [(number? v) (number->string v)] - [(string? v) (jsmaker-runtime-js-string v)] - [(char? v) (jsmaker-runtime-js-string (string v))] - [(symbol? v) (jsmaker-runtime-js-string (symbol->string v))] - [(keyword? v) (jsmaker-runtime-js-string (keyword->string v))] - [(null? v) "[]"] - [(pair? v) - (format "[~a]" (string-join (map jsmaker-runtime-value->js v) ", "))] - [(vector? v) - (format "[~a]" (string-join (map jsmaker-runtime-value->js (vector->list v)) ", "))] - [(hash? v) - (format "{~a}" - (string-join - (for/list ([(k val) (in-hash v)]) - (format "~a: ~a" (jsmaker-runtime-key->js k) (jsmaker-runtime-value->js val))) - ", "))] - [else - (error 'js "cannot interpolate Racket value as JavaScript literal: ~e" v)])) - -;; The js macro translates a practical Racket-expression subset to JavaScript. -;; It is intentionally syntax-driven: the Racket expressions are not evaluated. - -(begin-for-syntax - (struct unsupported (message datum) #:transparent) - - (define (fail who d) - (raise-syntax-error 'js (format "unsupported ~a: ~v" who d))) - - (define (indent s [prefix " "]) - (define lines (string-split s "\n" #:trim? #f)) - (string-join (map (λ (line) (if (string=? line "") line (string-append prefix line))) lines) "\n")) - - (define (join-lines xs) - (string-join (filter (λ (x) (and x (not (string=? x "")))) xs) "\n")) - - (define (escape-js-string s) - (define out (open-output-string)) - (for ([ch (in-string s)]) - (case ch - [(#\\) (display "\\\\" out)] - [(#\") (display "\\\"" out)] - [(#\newline) (display "\\n" out)] - [(#\return) (display "\\r" out)] - [(#\tab) (display "\\t" out)] - [else (display ch out)])) - (get-output-string out)) - - (define (js-string s) (format "\"~a\"" (escape-js-string s))) - - (define reserved-js - '(break case catch class const continue debugger default delete do else export extends - finally for function if import in instanceof let new return super switch this throw - try typeof var void while with yield enum await implements package protected static - interface private public null true false undefined NaN Infinity)) - - (define (replace-suffix s suffix replacement) - (if (string-suffix? s suffix) - (string-append (substring s 0 (- (string-length s) (string-length suffix))) replacement) - s)) - - (define (id->js x) - (define s0 (cond [(symbol? x) (symbol->string x)] [(keyword? x) (keyword->string x)] [else (format "~a" x)])) - (cond - [(member s0 '("...")) (fail "identifier" x)] - [(regexp-match? #rx"^[A-Za-z_$][A-Za-z0-9_$]*(\\.[A-Za-z_$][A-Za-z0-9_$]*)*$" s0) - (if (memq (string->symbol s0) reserved-js) (string-append s0 "_") s0)] - [else - (define parts (string-split s0 "." #:trim? #f)) - (define (clean part) - (define p1 (replace-suffix (replace-suffix (replace-suffix part "?" "_p") "!" "_bang") "->" "_to")) - (define p2 (regexp-replace* #rx"[^A-Za-z0-9_$]" p1 "_")) - (define p3 (if (regexp-match? #rx"^[A-Za-z_$]" p2) p2 (string-append "_" p2))) - (if (memq (string->symbol p3) reserved-js) (string-append p3 "_") p3)) - (string-join (map clean parts) ".")])) - - (define (prop->js x) - ;; Property names after a dot may legally be reserved words in modern - ;; JavaScript, for example promise.catch(...). Variable identifiers still - ;; use id->js, but method/property positions use this less restrictive - ;; mapper. - (define s0 (cond [(symbol? x) (symbol->string x)] [(keyword? x) (keyword->string x)] [else (format "~a" x)])) - (define s1 (replace-suffix (replace-suffix (replace-suffix s0 "?" "_p") "!" "_bang") "->" "_to")) - (define s2 (regexp-replace* #rx"[^A-Za-z0-9_$]" s1 "_")) - (if (regexp-match? #rx"^[A-Za-z_$]" s2) s2 (string-append "_" s2))) - - (define (dot-prop-symbol? x) - (and (symbol? x) - (let ([s (symbol->string x)]) - (and (> (string-length s) 1) - (char=? (string-ref s 0) #\.))))) - - (define (dot-prop->js x) - (prop->js (string->symbol (substring (symbol->string x) 1)))) - - (define (compile-assignment-target target) - (match target - [(? symbol?) (id->js target)] - [(list 'js-ref obj key) (format "~a[~a]" (compile-expr obj) (compile-expr key))] - [(list 'js-dot obj (? symbol? key)) (format "~a.~a" (compile-expr obj) (prop->js key))] - [_ (fail "assignment target" target)])) - - (define (compile-delete-target obj key) - (format "delete ~a[~a]" (compile-expr obj) (compile-expr key))) - - (define (object-binding-prop->js prop) - (match prop - [(list 'quote (? symbol? s)) (prop->js s)] - [(? symbol? s) (prop->js s)] - [(? keyword? kw) (prop->js kw)] - [(? string? s) s] - [_ (fail "object destructuring property" prop)])) - - (define (compile-object-destructure-pattern bindings) - (define parts - (for/list ([b (in-list bindings)]) - (match b - [(list id prop) - (format "~a: ~a" (object-binding-prop->js prop) (id->js id))] - [(list id prop default) - (format "~a: ~a = ~a" (object-binding-prop->js prop) (id->js id) (compile-expr default))] - [_ (fail "object destructuring binding" b)]))) - (format "{ ~a }" (string-join parts ", "))) - - (define (compile-let-object bindings obj body #:return-last? [return-last? #f] #:as-expression? [as-expression? #f]) - (define content - (join-lines - (list (format "const ~a = ~a;" (compile-object-destructure-pattern bindings) (compile-expr obj)) - (compile-body body #:return-last? return-last?)))) - (if as-expression? - (format "(() => ~a)()" (block content)) - (block content))) - - (define (compile-class-member m) - (match m - [(list 'constructor formals body ...) #:when (not (and (list? formals) (andmap list? formals))) - (format "constructor(~a) ~a" (compile-formals formals) (block (compile-body body)))] - [(list 'constructor bindings body ...) #:when (and (list? bindings) (andmap list? bindings)) - (define formals - (string-join - (for/list ([b (in-list bindings)]) - (match b - [(list id default) (format "~a = ~a" (id->js id) (compile-expr default))] - [(list id) (id->js id)] - [_ (fail "constructor binding" b)])) - ", ")) - (format "constructor(~a) ~a" formals (block (compile-body body)))] - [(list 'method (? symbol? name) formals body ...) - (format "~a(~a) ~a" (prop->js name) (compile-formals formals) (block (compile-body body #:return-last? #t)))] - [_ (fail "class member" m)])) - - (define (compile-define-class name members) - (format "class ~a { -~a -}" - (id->js name) - (indent (string-join (map compile-class-member members) " -")))) - - - (define (unsupported-regexp-reason src) - ;; JavaScript RegExp is close to Racket #px for common cases, but it is - ;; not PCRE/Racket. Reject known constructs that would silently change - ;; meaning or fail cryptically in JavaScript. This is deliberately a - ;; conservative syntax check, not a full regexp parser. - (cond - [(regexp-match? #rx"\\(\\?[imsxU-]" src) - "inline regexp option groups such as (?i:...) are not translated to JavaScript flags"] - [(regexp-match? #rx"\\(\\?>" src) - "atomic groups (?>...) are not supported by JavaScript RegExp"] - [(regexp-match? #rx"\\(\\?\\(" src) - "conditional regexp groups are not supported by JavaScript RegExp"] - [(regexp-match? #rx"\\(\\?P" src) - "Python/PCRE-style named groups (?P...) are not supported by JavaScript RegExp"] - [(regexp-match? #rx"\\\\[pP]\\{" src) - "Unicode property escapes are not emitted yet; JavaScript requires careful u-flag handling"] - [else #f])) - - (define (compile-regexp-literal rx) - (cond - [(or (byte-regexp? rx) (byte-pregexp? rx)) - (fail "byte regexp literal" rx)] - [else - (define src (object-name rx)) - (define reason (unsupported-regexp-reason src)) - (when reason (fail reason rx)) - (format "new RegExp(~a)" (js-string src))])) - - (define (literal->js v) - (cond - [(void? v) "undefined"] - [(eq? v #t) "true"] - [(eq? v #f) "false"] - [(regexp? v) (compile-regexp-literal v)] - [(or (byte-regexp? v) (byte-pregexp? v)) (fail "byte regexp literal" v)] - [(number? v) (number->string v)] - [(string? v) (js-string v)] - [(char? v) (js-string (string v))] - [(symbol? v) (js-string (symbol->string v))] - [(keyword? v) (js-string (keyword->string v))] - [(null? v) "[]"] - [(pair? v) (format "[~a]" (string-join (map literal->js v) ", "))] - [(vector? v) (format "[~a]" (string-join (map literal->js (vector->list v)) ", "))] - [else (fail "literal" v)])) - - (define (block stmt) - (string-append "{\n" (indent stmt) "\n}")) - - (define (parens s) (string-append "(" s ")")) - - (define (strip-one-outer-parens s) - (if (and (positive? (string-length s)) - (char=? (string-ref s 0) #\() - (char=? (string-ref s (sub1 (string-length s))) #\))) - (substring s 1 (sub1 (string-length s))) - s)) - - (define tmp-counter 0) - - (define (fresh prefix) - (set! tmp-counter (add1 tmp-counter)) - (format "__~a_~a" prefix tmp-counter)) - - ;; Runtime interpolation escape hatch. Before compiling the syntax to a - ;; datum, the public macros replace each (inject ) subform by a - ;; unique placeholder symbol. The historical alias (eval ) is - ;; kept for compatibility. The generated macro result is then a Racket - ;; expression that replaces those placeholders by JavaScript literals computed - ;; from in the use-site lexical context. This is intentionally - ;; different from JavaScript eval, which remains available as - ;; (send window eval ...) or by binding/calling another identifier. - (define (compile-racket-eval expr) - (fail "internal eval placeholder; public macro should rewrite eval first" expr)) - - (define (replace-racket-evals stx) - (define counter 0) - (define evals '()) - (define (fresh-eval-placeholder) - (set! counter (add1 counter)) - (string->symbol (format "__rkt_eval_slot_~a__" counter))) - (define (syntax-head-symbol x) - (define xs (syntax->list x)) - (and xs - (pair? xs) - (identifier? (car xs)) - (syntax-e (car xs)))) - (define (walk-pair p) - (cond - [(null? p) '()] - [(pair? p) (cons (walk (car p)) (walk-pair (cdr p)))] - [else (walk p)])) - (define (walk x) - (define e (if (syntax? x) (syntax-e x) x)) - (cond - [(syntax? x) - (case (syntax-head-symbol x) - [(quote quasiquote) (syntax->datum x)] - [(inject eval) - (define xs (syntax->list x)) - (cond - [(and xs (= (length xs) 2)) - (define ph (fresh-eval-placeholder)) - (set! evals (append evals (list (list (symbol->string ph) (cadr xs))))) - ph] - [else (walk-pair e)])] - [else - (cond - [(pair? e) (walk-pair e)] - [(vector? e) (list->vector (map walk (vector->list e)))] - [else e])])] - [(pair? e) (walk-pair e)] - [(vector? e) (list->vector (map walk (vector->list e)))] - [else e])) - (values (walk stx) evals)) - - (define (wrap-compiled-js stx compiled evals) - (for/fold ([acc #`#,compiled]) ([ev (in-list evals)]) - (define placeholder (first ev)) - (define racket-expr-stx (second ev)) - #`(string-replace #,acc - #,placeholder - (jsmaker-runtime-value->js - #,racket-expr-stx)))) - - ;; Racket conditionals treat only #f as false. JavaScript would also - ;; reject 0, "", null and undefined in condition position, so every - ;; Racket test is compiled through this helper. - (define (compile-test d) - (if (boolean-expr? d) - (let ([e (compile-expr d)]) - ;; Keep IIFEs intact: (() => {...})() starts and ends with parens, - ;; but removing the first/last character makes invalid JavaScript. - (if (regexp-match? #rx"=>" e) e (strip-one-outer-parens e))) - (format "(~a !== false)" (compile-expr d)))) - - (define (compile-arg-list args) - (string-join (map id->js args) ", ")) - - (define (split-formals formals) - (cond - [(null? formals) (values '() #f)] - [(symbol? formals) (values '() formals)] - [(pair? formals) - (let loop ([xs formals] [acc '()]) - (cond - [(null? xs) (values (reverse acc) #f)] - [(symbol? xs) (values (reverse acc) xs)] - [(pair? xs) (loop (cdr xs) (cons (car xs) acc))] - [else (fail "formals" formals)]))] - [else (fail "formals" formals)])) - - (define (compile-formals formals) - (define-values (pos rest) (split-formals formals)) - (define pos-js (map id->js pos)) - (define all-js (if rest (append pos-js (list (string-append "..." (id->js rest)))) pos-js)) - (string-join all-js ", ")) - - (define (binding-id b) - (match b - [(list id _) id] - [(list id _ ...) id] - [_ (fail "binding" b)])) - - (define (binding-rhs b) - (match b - [(list _ rhs) rhs] - [_ (fail "binding" b)])) - - (define (binding-ids b) - (match b - [(list ids _) ids] - [_ (fail "value binding" b)])) - - (define (ids-pattern->js ids) - (cond - [(and (list? ids) (= (length ids) 1)) (id->js (car ids))] - [(list? ids) (format "[~a]" (compile-arg-list ids))] - [(symbol? ids) (id->js ids)] - [else (fail "binding ids" ids)])) - - (define (definition? d) - (match d - [(list 'define _ ...) #t] - [(list 'define-values _ ...) #t] - [_ #f])) - - (define (return-form? d) - (match d - [(list 'return _) #t] - [_ #f])) - - (define (compile-body body #:return-last? [return-last? #f]) - (cond - [(null? body) (if return-last? "return undefined;" "")] - [else - (define n (length body)) - (join-lines - (for/list ([form (in-list body)] [i (in-naturals)]) - (define last? (= i (sub1 n))) - (if (and return-last? last? (not (definition? form))) - (compile-return form) - (compile-stmt form))))])) - - (define (compile-return d) - (match d - [(list 'return) "return undefined;"] - [(list 'return e) (format "return ~a;" (compile-expr e))] - [(list 'begin es ...) - (compile-body es #:return-last? #t)] - [(list 'if c t e) - (format "if (~a) ~a else ~a" (compile-test c) - (block (compile-body (list t) #:return-last? #t)) - (block (compile-body (list e) #:return-last? #t)))] - [(list 'cond clauses ...) - (compile-cond clauses #:return-last? #t)] - [(list 'with-handlers clauses body ...) - (compile-with-handlers clauses body #:return-last? #t #:as-expression? #f)] - [(list 'let name bindings body ...) #:when (symbol? name) - (compile-named-let name bindings body #:return-last? #t #:as-expression? #f)] - [(list 'let bindings body ...) - (compile-let 'let bindings body #:return-last? #t #:as-expression? #f)] - [(list 'let* bindings body ...) - (compile-let 'let* bindings body #:return-last? #t #:as-expression? #f)] - [(list 'letrec bindings body ...) - (compile-let 'letrec bindings body #:return-last? #t #:as-expression? #f)] - [(list 'let-values bindings body ...) - (compile-let-values 'let-values bindings body #:return-last? #t #:as-expression? #f)] - [(list 'let*-values bindings body ...) - (compile-let-values 'let*-values bindings body #:return-last? #t #:as-expression? #f)] - [(list 'when c body ...) - (format "if (~a) ~a\nreturn undefined;" (compile-expr c) (block (compile-body body)))] - [(list 'unless c body ...) - (format "if (!(~a)) ~a\nreturn undefined;" (compile-expr c) (block (compile-body body)))] - [(list 'set! _ ...) - (join-lines (list (compile-stmt d) "return undefined;"))] - [(list 'vector-set! _ ...) - (join-lines (list (compile-stmt d) "return undefined;"))] - [(list 'set-prop! _ ...) - (join-lines (list (compile-stmt d) "return undefined;"))] - [(list 'delete-prop! _ ...) - (join-lines (list (compile-stmt d) "return undefined;"))] - [_ (format "return ~a;" (compile-expr d))])) - - (define (compile-stmt d) - (match d - [(list 'begin es ...) - (compile-body es)] - [(list 'begin0 first rest ...) - (join-lines (cons (compile-stmt first) (map compile-stmt rest)))] - [(list 'define (? pair? sig) body ...) - (format "function ~a(~a) ~a" (id->js (car sig)) (compile-formals (cdr sig)) (block (compile-body body #:return-last? #t)))] - [(list 'define id rhs) - (format "let ~a = ~a;" (id->js id) (compile-expr rhs))] - [(list 'define-values (list id) rhs) - (format "let ~a = ~a;" (id->js id) (compile-expr rhs))] - [(list 'define-values ids rhs) - (format "let [~a] = ~a;" (compile-arg-list ids) (compile-expr rhs))] - [(list 'set! obj (? dot-prop-symbol? prop) rhs) - (format "~a.~a = ~a;" (compile-expr obj) (dot-prop->js prop) (compile-expr rhs))] - [(list 'set! target rhs) - (format "~a = ~a;" (compile-assignment-target target) (compile-expr rhs))] - [(list 'return) - "return undefined;"] - [(list 'return e) - (format "return ~a;" (compile-expr e))] - [(list 'while c body ...) - (format "while (~a) ~a" (compile-test c) (block (compile-body body)))] - [(list 'if c t e) - (format "if (~a) ~a else ~a" (compile-test c) (block (compile-body (list t))) (block (compile-body (list e))))] - [(list 'cond clauses ...) - (compile-cond clauses #:return-last? #f)] - [(list 'with-handlers clauses body ...) - (compile-with-handlers clauses body #:return-last? #f #:as-expression? #f)] - [(list 'case key clauses ...) - (compile-case key clauses #:return-last? #f)] - [(list 'when c body ...) - (format "if (~a) ~a" (compile-test c) (block (compile-body body)))] - [(list 'unless c body ...) - (format "if (!(~a)) ~a" (compile-test c) (block (compile-body body)))] - [(list 'let name bindings body ...) #:when (symbol? name) - (compile-named-let name bindings body #:return-last? #f #:as-expression? #f)] - [(list 'let bindings body ...) - (compile-let 'let bindings body #:return-last? #f #:as-expression? #f)] - [(list 'let* bindings body ...) - (compile-let 'let* bindings body #:return-last? #f #:as-expression? #f)] - [(list 'letrec bindings body ...) - (compile-let 'letrec bindings body #:return-last? #f #:as-expression? #f)] - [(list 'let-values bindings body ...) - (compile-let-values 'let-values bindings body #:return-last? #f #:as-expression? #f)] - [(list 'let*-values bindings body ...) - (compile-let-values 'let*-values bindings body #:return-last? #f #:as-expression? #f)] - [(list 'for clauses body ...) - (compile-for clauses body #:collect? #f #:as-expression? #f)] - [(list 'for/list clauses body ...) - (format "~a;" (compile-for clauses body #:collect? #t #:as-expression? #t))] - [(list 'for/vector clauses body ...) - (format "~a;" (compile-for clauses body #:collect? #t #:as-expression? #t))] - [(list 'vector-set! v i val) - (format "~a[~a] = ~a;" (compile-expr v) (compile-expr i) (compile-expr val))] - [(list 'set-prop! obj key val) - (format "~a[~a] = ~a;" (compile-expr obj) (compile-expr key) (compile-expr val))] - [(list 'delete-prop! obj key) - (format "~a;" (compile-delete-target obj key))] - [(list 'let-object bindings obj body ...) - (compile-let-object bindings obj body #:return-last? #f #:as-expression? #f)] - [(list 'define-class name members ...) - (compile-define-class name members)] - [(list 'send obj method args ...) - (format "~a.~a(~a);" (compile-expr obj) (prop->js method) (string-join (map compile-expr args) ", "))] - [_ - (format "~a;" (compile-expr d))])) - - (define (compile-let kind bindings body #:return-last? [return-last? #f] #:as-expression? [as-expression? #f]) - (define (body-code) (compile-body body #:return-last? return-last?)) - (define content - (case kind - [(let) - ;; Racket let evaluates all RHS expressions before introducing the new - ;; bindings. The common case can still be emitted directly when no RHS - ;; mentions one of the newly-bound identifiers. If it does, use temps - ;; to avoid JavaScript TDZ bugs for code such as (let ([x x]) ...), - ;; where the RHS must see the outer x. - (define ids (map binding-id bindings)) - (define (mentions-id? x id) - (cond - [(symbol? x) (eq? x id)] - [(pair? x) (or (mentions-id? (car x) id) (mentions-id? (cdr x) id))] - [(vector? x) (for/or ([e (in-vector x)]) (mentions-id? e id))] - [else #f])) - (define (mentions-any-bound-id? rhs) - (for/or ([id (in-list ids)]) (mentions-id? rhs id))) - (cond - [(for/or ([b (in-list bindings)]) (mentions-any-bound-id? (binding-rhs b))) - (define tmps (for/list ([_ (in-list bindings)]) (fresh "let_value"))) - (define rhs-stmts - (for/list ([tmp (in-list tmps)] [b (in-list bindings)]) - (format "const ~a = ~a;" tmp (compile-expr (binding-rhs b))))) - (define bind-stmts - (for/list ([tmp (in-list tmps)] [b (in-list bindings)]) - (format "let ~a = ~a;" (id->js (binding-id b)) tmp))) - (join-lines (append rhs-stmts (list (block (join-lines (append bind-stmts (list (body-code))))))))] - [else - (join-lines - (append - (for/list ([b (in-list bindings)]) - (format "let ~a = ~a;" (id->js (binding-id b)) (compile-expr (binding-rhs b)))) - (list (body-code))))])] - [(let*) - ;; Emit the common case directly: - ;; (let* ([x 10] [y (+ x x)]) body) - ;; becomes one JavaScript block with sequential let bindings. Only - ;; when a RHS mentions the same identifier that is being introduced, - ;; such as (let* ([x x]) ...), do we use a temporary to preserve - ;; Racket semantics and avoid JavaScript's temporal-dead-zone error. - (define (mentions-id? x id) - (cond - [(symbol? x) (eq? x id)] - [(pair? x) (or (mentions-id? (car x) id) (mentions-id? (cdr x) id))] - [else #f])) - (define (emit bs) - (cond - [(null? bs) (body-code)] - [else - (define b (car bs)) - (define id (binding-id b)) - (define rhs (binding-rhs b)) - (cond - [(mentions-id? rhs id) - (define tmp (fresh "let_star_value")) - (join-lines - (list (format "const ~a = ~a;" tmp (compile-expr rhs)) - (block (join-lines - (list (format "let ~a = ~a;" (id->js id) tmp) - (emit (cdr bs)))))))] - [else - (join-lines - (list (format "let ~a = ~a;" (id->js id) (compile-expr rhs)) - (emit (cdr bs))))])])) - (emit bindings)] - [(letrec) - (define decls (for/list ([b (in-list bindings)]) (format "let ~a;" (id->js (binding-id b))))) - (define sets (for/list ([b (in-list bindings)]) (format "~a = ~a;" (id->js (binding-id b)) (compile-expr (binding-rhs b))))) - (join-lines (append decls sets (list (body-code))))] - [else (fail "let kind" kind)])) - (if as-expression? - (format "(() => ~a)()" (block content)) - (block content))) - - (define (compile-let-values kind bindings body #:return-last? [return-last? #f] #:as-expression? [as-expression? #f]) - (define (body-code) (compile-body body #:return-last? return-last?)) - (define (bind-stmt ids tmp) (format "let ~a = ~a;" (ids-pattern->js ids) tmp)) - (define content - (case kind - [(let-values) - (define tmps (for/list ([_ (in-list bindings)]) (fresh "let_values"))) - (define rhs-stmts - (for/list ([tmp (in-list tmps)] [b (in-list bindings)]) - (format "const ~a = ~a;" tmp (compile-expr (binding-rhs b))))) - (define bind-stmts - (for/list ([tmp (in-list tmps)] [b (in-list bindings)]) - (bind-stmt (binding-ids b) tmp))) - (join-lines (append rhs-stmts (list (block (join-lines (append bind-stmts (list (body-code))))))))] - [(let*-values) - (define (emit bs) - (cond - [(null? bs) (body-code)] - [else - (define b (car bs)) - (define tmp (fresh "let_star_values")) - (join-lines (list (format "const ~a = ~a;" tmp (compile-expr (binding-rhs b))) - (block (join-lines (list (bind-stmt (binding-ids b) tmp) (emit (cdr bs)))))))])) - (emit bindings)] - [else (fail "let-values kind" kind)])) - (if as-expression? - (format "(() => ~a)()" (block content)) - (block content))) - - (define (compile-named-let name bindings body #:return-last? [return-last? #f] #:as-expression? [as-expression? #f]) - ;; Tail-recursive named let is emitted as a JavaScript loop. This covers - ;; the common Racket idiom: - ;; (let loop ([i 0] [acc 0]) - ;; (if (...) (loop ...) acc)) - ;; without consuming the JavaScript call stack. - (define ids (map binding-id bindings)) - (define vals (map binding-rhs bindings)) - (define loop-name (id->js name)) - (define init-stmts - (for/list ([id (in-list ids)] [v (in-list vals)]) - (format "let ~a = ~a;" (id->js id) (compile-expr v)))) - (define (tail-call? d) - (and (pair? d) (eq? (car d) name))) - (define (emit-tail d) - (match d - [(list 'begin es ...) - (compile-tail-sequence es)] - [(list 'if c t e) - (format "if (~a) ~a else ~a" - (compile-test c) - (block (emit-tail t)) - (block (emit-tail e)))] - [(list 'cond clauses ...) - (compile-cond clauses #:return-last? return-last?)] - [(? tail-call?) - (define args (cdr d)) - (unless (= (length args) (length ids)) - (fail "named let arity" d)) - (define temps (for/list ([_ (in-list args)]) (fresh "loop_arg"))) - (join-lines - (append - (for/list ([tmp (in-list temps)] [arg (in-list args)]) - (format "const ~a = ~a;" tmp (compile-expr arg))) - (for/list ([id (in-list ids)] [tmp (in-list temps)]) - (format "~a = ~a;" (id->js id) tmp)) - (list "continue;")))] - [_ - (if return-last? - (format "return ~a;" (compile-expr d)) - (format "~a; -break;" (compile-expr d)))])) - (define (compile-tail-sequence es) - (cond - [(null? es) (if return-last? "return undefined;" "break;")] - [(null? (cdr es)) (emit-tail (car es))] - [else (join-lines (append (map compile-stmt (reverse (cdr (reverse es)))) - (list (emit-tail (car (reverse es))))))])) - (define content - (join-lines (append init-stmts - (list (format "while (true) ~a" - (block (compile-tail-sequence body))))))) - (if as-expression? - (format "(() => ~a)()" (block content)) - (block content))) - - (define (compile-cond clauses #:return-last? [return-last? #f]) - (define (emit-result expr) - (if return-last? (format "return ~a;" expr) (format "~a;" expr))) - (define (emit-then test-tmp c) - (match c - [(list _ '=> proc) - (emit-result (format "~a(~a)" (compile-callee proc) test-tmp))] - [(list _) - (emit-result test-tmp)] - [(list _ body ...) - (if return-last? (compile-body body #:return-last? #t) (compile-body body))] - [_ (fail "cond clause" c)])) - (define (loop cs) - (cond - [(null? cs) (if return-last? "return undefined;" "")] - [else - (define c (car cs)) - (match c - [(list 'else body ...) - (if return-last? (compile-body body #:return-last? #t) (compile-body body))] - [(list test _ ...) - (define tmp (fresh "cond_value")) - (define else-part (loop (cdr cs))) - (define then-block (block (emit-then tmp c))) - (join-lines - (list (format "const ~a = ~a;" tmp (compile-expr test)) - (if (string=? else-part "") - (format "if (~a !== false) ~a" tmp then-block) - (format "if (~a !== false) ~a else ~a" tmp then-block (block else-part)))))] - [_ (fail "cond clause" c)])])) - (loop clauses)) - - (define (compile-case key clauses #:return-last? [return-last? #f]) - (define key-js (compile-expr key)) - (define tmp "__case_value") - (define (compile-clause c) - (match c - [(list 'else body ...) - (string-append "default:\n" (indent (compile-body body #:return-last? return-last?)))] - [(list datums body ...) - (define tests (for/list ([d (in-list datums)]) (format "case ~a:" (literal->js d)))) - (string-append (string-join tests "\n") "\n" (indent (compile-body body #:return-last? return-last?)) "\n break;")] - [_ (fail "case clause" c)])) - (format "{\n const ~a = ~a;\n switch (~a) {\n~a\n }\n}" - tmp key-js tmp (indent (string-join (map compile-clause clauses) "\n") " "))) - - (define (compile-if-expr c t e) - (format "(~a ? ~a : ~a)" (compile-test c) (compile-expr t) (compile-expr e))) - - (define (compile-begin-expr es) - (format "(() => ~a)()" (block (compile-body es #:return-last? #t)))) - - (define (compile-hash args) - (unless (even? (length args)) (fail "hash expression with odd number of arguments" args)) - (define pairs - (for/list ([k (in-list args)] [v (in-list (cdr args))] [i (in-naturals)] #:when (even? i)) - (define key - (match k - [(list 'quote (? symbol? s)) (symbol->string s)] - [(? keyword? kw) (keyword->string kw)] - [(? symbol? s) (symbol->string s)] - [(? string? s) s] - [_ #f])) - (if key - (format "~a: ~a" (if (regexp-match? #rx"^[A-Za-z_$][A-Za-z0-9_$]*$" key) key (js-string key)) (compile-expr v)) - (format "[~a]: ~a" (compile-expr k) (compile-expr v))))) - (format "{~a}" (string-join pairs ", "))) - - (define (compile-make-hash args) - (match args - ['() "{}"] - [(list entries) (format "Object.fromEntries(~a)" (compile-expr entries))] - [_ (fail "make-hash arity" args)])) - - (define (compile-hash-ref args) - (match args - [(list h k) - (format "~a[~a]" (parens (compile-expr h)) (compile-expr k))] - [(list h k default) - (format "((__h, __k, __default) => Object.prototype.hasOwnProperty.call(__h, __k) ? __h[__k] : (typeof __default === 'function' ? __default() : __default))(~a, ~a, ~a)" - (compile-expr h) (compile-expr k) (compile-expr default))] - [_ (fail "hash-ref" args)])) - - (define (compile-hash-set args #:mutate? [mutate? #f]) - (match args - [(list h k v) - (if mutate? - (format "((__h, __k, __v) => { __h[__k] = __v; return undefined; })(~a, ~a, ~a)" - (compile-expr h) (compile-expr k) (compile-expr v)) - (format "Object.assign({}, ~a, { [~a]: ~a })" - (compile-expr h) (compile-expr k) (compile-expr v)))] - [_ (fail (if mutate? "hash-set!" "hash-set") args)])) - - (define (compile-hash-remove args #:mutate? [mutate? #f]) - (match args - [(list h k) - (if mutate? - (format "((__h, __k) => { delete __h[__k]; return undefined; })(~a, ~a)" - (compile-expr h) (compile-expr k)) - (format "((__h, __k) => { const __out = Object.assign({}, __h); delete __out[__k]; return __out; })(~a, ~a)" - (compile-expr h) (compile-expr k)))] - [_ (fail (if mutate? "hash-remove!" "hash-remove") args)])) - - (define (compile-hash-update args #:mutate? [mutate? #f]) - (match args - [(list h k f) - (format "((__h, __k, __f) => { if (!Object.prototype.hasOwnProperty.call(__h, __k)) throw new Error('hash-update: no value found for key'); ~a; return ~a; })(~a, ~a, ~a)" - (if mutate? "__h[__k] = __f(__h[__k])" "const __out = Object.assign({}, __h); __out[__k] = __f(__h[__k])") - (if mutate? "undefined" "__out") - (compile-expr h) (compile-expr k) (compile-expr f))] - [(list h k f default) - (format "((__h, __k, __f, __default) => { const __old = Object.prototype.hasOwnProperty.call(__h, __k) ? __h[__k] : (typeof __default === 'function' ? __default() : __default); ~a; return ~a; })(~a, ~a, ~a, ~a)" - (if mutate? "__h[__k] = __f(__old)" "const __out = Object.assign({}, __h); __out[__k] = __f(__old)") - (if mutate? "undefined" "__out") - (compile-expr h) (compile-expr k) (compile-expr f) (compile-expr default))] - [_ (fail (if mutate? "hash-update!" "hash-update") args)])) - - (define (compile-hash-clear args #:mutate? [mutate? #f]) - (match args - [(list h) - (if mutate? - (format "((__h) => { for (const __k of Object.keys(__h)) delete __h[__k]; return undefined; })(~a)" - (compile-expr h)) - "{}")] - [_ (fail (if mutate? "hash-clear!" "hash-clear") args)])) - - (define (atomic-expr? x) - (or (boolean? x) - (number? x) - (string? x) - (char? x) - (keyword? x) - (regexp? x) - (and (symbol? x) (not (memq x '(#%app quote quasiquote lambda λ if begin let let* letrec cond case for for/list for/vector for/fold values return while)))) - (and (pair? x) (eq? (car x) 'quote)))) - - (define (boolean-expr? x) - (or (boolean? x) - (and (pair? x) - (let ([op (car x)]) - (or (memq op '(< > <= >= = == equal? eq? eqv? != not-equal? - zero? positive? negative? even? odd? - null? empty? pair? list? vector? number? real? integer? - string? boolean? symbol? regexp? pregexp? regexp-match? - string=? string-ci=? string? string<=? string>=? - hash? hash-has-key? not)) - (and (eq? op 'and) (andmap boolean-expr? (cdr x))) - (and (eq? op 'or) (andmap boolean-expr? (cdr x)))))))) - - (define (compile-pairwise args make-test) - (cond - [(or (null? args) (null? (cdr args))) "true"] - [(andmap atomic-expr? args) - (define compiled (map compile-expr args)) - (define tests - (for/list ([a (in-list compiled)] [b (in-list (cdr compiled))]) - (make-test a b))) - (if (null? (cdr tests)) (car tests) (parens (string-join tests " && ")))] - [else - (define temps (for/list ([_ (in-list args)]) (fresh "cmp"))) - (define bindings - (for/list ([tmp (in-list temps)] [arg (in-list args)]) - (format "const ~a = ~a;" tmp (compile-expr arg)))) - (define tests - (for/list ([a (in-list temps)] [b (in-list (cdr temps))]) - (make-test a b))) - (format "(() => ~a)()" - (block (join-lines (append bindings - (list (format "return ~a;" (string-join tests " && ")))))))])) - - (define (compile-comparison jsop args) - (compile-pairwise args (λ (a b) (format "(~a ~a ~a)" a jsop b)))) - - (define (compile-object-is args) - (compile-pairwise args (λ (a b) (format "Object.is(~a, ~a)" a b)))) - - (define (compile-deep-equal args) - (compile-pairwise - args - (λ (a b) - (format "(Object.is(~a, ~a) || JSON.stringify(~a) === JSON.stringify(~a))" a b a b)))) - - (define (compile-and args) - (cond - [(null? args) "true"] - [(null? (cdr args)) (compile-expr (car args))] - [(andmap boolean-expr? args) - (parens (string-join (map compile-expr args) " && "))] - [else - (define tmp (fresh "and_value")) - (define non-last (reverse (cdr (reverse args)))) - (define last-arg (car (reverse args))) - (define steps - (append - (list (format "let ~a = ~a;" tmp (compile-expr (car non-last))) - (format "if (~a === false) return false;" tmp)) - (for/list ([arg (in-list (cdr non-last))]) - (format "~a = ~a; -if (~a === false) return false;" tmp (compile-expr arg) tmp)) - (list (format "return ~a;" (compile-expr last-arg))))) - (format "(() => ~a)()" (block (join-lines steps)))])) - - (define (compile-or args) - (cond - [(null? args) "false"] - [(andmap boolean-expr? args) - (parens (string-join (map compile-expr args) " || "))] - [else - (define tmp (fresh "or_value")) - (define steps - (for/list ([arg (in-list args)]) - (format "~a = ~a; -if (~a !== false) return ~a;" tmp (compile-expr arg) tmp tmp))) - (format "(() => ~a)()" - (block (join-lines (append (list (format "let ~a = false;" tmp)) - steps - (list "return false;")))))])) - - (define (compile-sequence d) - (match d - [(list 'in-list xs) (compile-expr xs)] - [(list 'in-vector xs) (compile-expr xs)] - [(list 'in-string xs) (format "Array.from(~a)" (compile-expr xs))] - [(list 'in-range end) - (format "((__end) => { const __out = []; for (let __i = 0; __i < __end; __i++) __out.push(__i); return __out; })(~a)" - (compile-expr end))] - [(list 'in-range start end) - (format "((__start, __end) => { const __out = []; for (let __i = __start; __i < __end; __i++) __out.push(__i); return __out; })(~a, ~a)" - (compile-expr start) (compile-expr end))] - [(list 'in-range start end step) - (format "((__start, __end, __step) => { const __out = []; for (let __i = __start; (__step >= 0 ? __i < __end : __i > __end); __i += __step) __out.push(__i); return __out; })(~a, ~a, ~a)" - (compile-expr start) (compile-expr end) (compile-expr step))] - [_ (compile-expr d)])) - - (define (compile-body-as-expr body) - (cond - [(null? body) "undefined"] - [(null? (cdr body)) (compile-expr (car body))] - [else (compile-begin-expr body)])) - - (define (compile-callee f) - ;; A lambda in callee position must be emitted as a function expression, - ;; not as a function declaration statement. Parenthesizing compound - ;; callees is harmless and prevents invalid code such as: - ;; function(...args) { ... }(__exn) - (define f-js (compile-expr f)) - (if (symbol? f) f-js (parens f-js))) - - (define (compile-for clauses body #:collect? [collect? #f] #:as-expression? [as-expression? #t]) - (define out (fresh "for_out")) - (define (emit clauses*) - (cond - [(null? clauses*) - (if collect? - (format "~a.push(~a);" out (compile-body-as-expr body)) - (compile-body body))] - [else - (define c (car clauses*)) - (cond - [(eq? c '#:when) - (match (cdr clauses*) - [(list test more ...) (format "if (~a) ~a" (compile-test test) (block (emit more)))] - [_ (fail "for #:when clause" clauses*)])] - [(eq? c '#:unless) - (match (cdr clauses*) - [(list test more ...) (format "if (!(~a)) ~a" (compile-test test) (block (emit more)))] - [_ (fail "for #:unless clause" clauses*)])] - [else - (match c - [(list id seq) - (format "for (const ~a of ~a) ~a" (id->js id) (compile-sequence seq) (block (emit (cdr clauses*))))] - [_ (fail "for clause" c)])])])) - (define content - (if collect? - (join-lines (list (format "const ~a = [];" out) (emit clauses) (format "return ~a;" out))) - (emit clauses))) - (cond - [as-expression? (format "(() => ~a)()" (block content))] - [else content])) - - (define (compile-for-fold bindings clauses body) - (define ids (map binding-id bindings)) - (define init-stmts - (for/list ([b (in-list bindings)]) - (format "let ~a = ~a;" (id->js (binding-id b)) (compile-expr (binding-rhs b))))) - (define body-expr (compile-body-as-expr body)) - (define update - (if (= (length ids) 1) - (format "~a = ~a;" (id->js (car ids)) body-expr) - (format "[~a] = ~a;" (compile-arg-list ids) body-expr))) - (define (emit clauses*) - (cond - [(null? clauses*) update] - [else - (define c (car clauses*)) - (cond - [(eq? c '#:when) - (match (cdr clauses*) - [(list test more ...) (format "if (~a) ~a" (compile-test test) (block (emit more)))] - [_ (fail "for/fold #:when clause" clauses*)])] - [(eq? c '#:unless) - (match (cdr clauses*) - [(list test more ...) (format "if (!(~a)) ~a" (compile-test test) (block (emit more)))] - [_ (fail "for/fold #:unless clause" clauses*)])] - [else - (match c - [(list id seq) - (format "for (const ~a of ~a) ~a" (id->js id) (compile-sequence seq) (block (emit (cdr clauses*))))] - [_ (fail "for/fold clause" c)])])])) - (format "(() => ~a)()" - (block (join-lines (append init-stmts - (list (emit clauses) - (if (= (length ids) 1) - (format "return ~a;" (id->js (car ids))) - (format "return [~a];" (compile-arg-list ids))))))))) - - (define (regexp-arg->js pat) - (format "__rkt_to_regexp(~a, false)" (compile-expr pat))) - - (define (regexp-arg->js/global pat) - (format "__rkt_to_regexp(~a, true)" (compile-expr pat))) - - (define (inline-regexp-runtime expr) - (format "((__rkt_body) => {\n const __rkt_to_regexp = (__pat, __global) => {\n const __flags = (__pat instanceof RegExp)\n ? Array.from(new Set((__pat.flags.replace(/g/g, '') + (__global ? 'g' : '')).split(''))).join('')\n : (__global ? 'g' : '');\n return (__pat instanceof RegExp) ? new RegExp(__pat.source, __flags) : new RegExp(String(__pat), __flags);\n };\n const __rkt_match_array = (__m) => (__m === null ? false : Array.from(__m, (__x) => __x === undefined ? false : __x));\n const __rkt_replacement = (__s) => {\n if (typeof __s !== 'string') return __s;\n let __out = '';\n for (let __i = 0; __i < __s.length; __i++) {\n const __ch = __s[__i];\n if (__ch === '$') { __out += '$$'; continue; }\n if (__ch === '\\\\' && __i + 1 < __s.length) {\n const __n = __s[++__i];\n if (__n >= '0' && __n <= '9') __out += (__n === '0' ? '$&' : ('$' + __n));\n else __out += __n;\n } else __out += __ch;\n }\n return __out;\n };\n return __rkt_body(__rkt_to_regexp, __rkt_match_array, __rkt_replacement);\n})((__rkt_to_regexp, __rkt_match_array, __rkt_replacement) => ~a)" expr)) - - (define (compile-regexp-match args) - (match args - [(list pat s) - (inline-regexp-runtime - (format "__rkt_match_array(String(~a).match(~a))" (compile-expr s) (regexp-arg->js pat)))] - [(list pat s start) - (inline-regexp-runtime - (format "__rkt_match_array(String(~a).slice(~a).match(~a))" - (compile-expr s) (compile-expr start) (regexp-arg->js pat)))] - [_ (fail "regexp-match arity" args)])) - - (define (compile-regexp-match? args) - (match args - [(list pat s) - (inline-regexp-runtime - (format "~a.test(String(~a))" (regexp-arg->js pat) (compile-expr s)))] - [(list pat s start) - (inline-regexp-runtime - (format "~a.test(String(~a).slice(~a))" (regexp-arg->js pat) (compile-expr s) (compile-expr start)))] - [_ (fail "regexp-match? arity" args)])) - - (define (compile-regexp-match* args) - (match args - [(list pat s) - (inline-regexp-runtime - (format "Array.from(String(~a).matchAll(~a), (__m) => __m[0])" - (compile-expr s) (regexp-arg->js/global pat)))] - [(list pat s start) - (inline-regexp-runtime - (format "Array.from(String(~a).slice(~a).matchAll(~a), (__m) => __m[0])" - (compile-expr s) (compile-expr start) (regexp-arg->js/global pat)))] - [_ (fail "regexp-match* arity" args)])) - - (define (compile-regexp-match-positions args) - (match args - [(list pat s) - (inline-regexp-runtime - (format "((__s, __rx) => { const __m = __rx.exec(__s); if (__m === null) return false; return __m.map((__x, __i) => { if (__x === undefined) return false; const __start = __m.indices ? __m.indices[__i][0] : (__i === 0 ? __m.index : __s.indexOf(__x, __m.index)); return [__start, __start + __x.length]; }); })(String(~a), (() => { const __rx = ~a; return new RegExp(__rx.source, Array.from(new Set((__rx.flags.replace(/g/g, '') + 'd').split(''))).join('')); })())" - (compile-expr s) (regexp-arg->js pat)))] - [_ (fail "regexp-match-positions arity" args)])) - - (define (compile-regexp-split args) - (match args - [(list pat s) - (inline-regexp-runtime - (format "String(~a).split(~a)" (compile-expr s) (regexp-arg->js/global pat)))] - [_ (fail "regexp-split arity" args)])) - - (define (compile-regexp-replace args #:all? all?) - (match args - [(list pat s repl) - (inline-regexp-runtime - (format "String(~a).replace(~a, __rkt_replacement(~a))" - (compile-expr s) - ((if all? regexp-arg->js/global regexp-arg->js) pat) - (compile-expr repl)))] - [_ (fail (if all? "regexp-replace* arity" "regexp-replace arity") args)])) - - (define (compile-regexp-quote args) - (match args - [(list s) - (format "String(~a).replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&')" (compile-expr s))] - [_ (fail "regexp-quote arity" args)])) - - - (define (handler-predicate-supported? pred) - ;; Deliberately narrow: js-maker only models one JavaScript catch channel. - ;; It therefore supports generic exn? handlers, not the Racket exception - ;; predicate hierarchy. - (eq? pred 'exn?)) - - (define (compile-with-handlers clauses body #:return-last? [return-last? #t] #:as-expression? [as-expression? #t]) - (unless (and (list? clauses) (andmap list? clauses)) - (fail "with-handlers clauses" clauses)) - (define catch-var (fresh "exn")) - (define (emit-handler cs) - (cond - [(null? cs) (format "throw ~a;" catch-var)] - [else - (match (car cs) - [(list (? symbol? pred) handler) - (unless (handler-predicate-supported? pred) - (fail "with-handlers predicate; only generic exn? is supported" pred)) - (define call (format "~a(~a)" (compile-callee handler) catch-var)) - (if return-last? (format "return ~a;" call) (format "~a;" call))] - [_ (fail "with-handlers clause" (car cs))])])) - (define content - (format "try ~a catch (~a) ~a" - (block (compile-body body #:return-last? return-last?)) - catch-var - (block (emit-handler clauses)))) - (if as-expression? (format "(() => ~a)()" (block content)) content)) - - (define (identifier-local-name op) - ;; Gregor is commonly imported with a prefix, but that prefix is not - ;; stable in user code. This helper strips an arbitrary prefix ending in - ;; ':' and matches on the local binding name. It is intentionally only - ;; used by the small Gregor compatibility table below. - (define s (symbol->string op)) - (define parts (string-split s ":")) - (if (null? parts) s (car (reverse parts)))) - - (define (inline-gregor-runtime expr) - ;; Small JS-side value model for Gregor-like date/time values. Plain dates - ;; and times remain timezone-independent tagged objects. Explicit - ;; ->js-date conversion yields a native JavaScript Date. - (format "((__rkt_body) => {\n const __pad = (__n, __w = 2) => String(__n).padStart(__w, '0');\n const __date = (__y, __m, __d) => ({__gregor: 'date', year: Number(__y), month: Number(__m), day: Number(__d)});\n const __time = (__h, __m, __s = 0) => ({__gregor: 'time', hour: Number(__h), minute: Number(__m), second: Number(__s)});\n const __datetime = (__y, __mo, __d, __h = 0, __mi = 0, __s = 0) => ({__gregor: 'datetime', year: Number(__y), month: Number(__mo), day: Number(__d), hour: Number(__h), minute: Number(__mi), second: Number(__s)});\n const __parse_date = (__s) => { const __m = String(__s).match(/^(\\d{4})-(\\d{2})-(\\d{2})$/); if (!__m) throw new Error('invalid date: ' + __s); return __date(__m[1], __m[2], __m[3]); };\n const __parse_time = (__s) => { const __m = String(__s).match(/^(\\d{2}):(\\d{2})(?::(\\d{2}))?$/); if (!__m) throw new Error('invalid time: ' + __s); return __time(__m[1], __m[2], __m[3] || 0); };\n const __parse_datetime = (__s) => { const __m = String(__s).match(/^(\\d{4})-(\\d{2})-(\\d{2})[T ](\\d{2}):(\\d{2})(?::(\\d{2}))?(?:Z|[+-]\\d{2}:?\\d{2})?$/); if (!__m) throw new Error('invalid datetime: ' + __s); return __datetime(__m[1], __m[2], __m[3], __m[4], __m[5], __m[6] || 0); };\n const __from_js_date = (__x) => __datetime(__x.getFullYear(), __x.getMonth() + 1, __x.getDate(), __x.getHours(), __x.getMinutes(), __x.getSeconds());\n const __to_js_date = (__x) => { if (__x instanceof Date) return __x; if (__x.__gregor === 'date') return new Date(__x.year, __x.month - 1, __x.day); if (__x.__gregor === 'time') return new Date(1970, 0, 1, __x.hour, __x.minute, __x.second || 0); return new Date(__x.year, __x.month - 1, __x.day, __x.hour || 0, __x.minute || 0, __x.second || 0); };\n const __date_string = (__x) => `${__pad(__x.year, 4)}-${__pad(__x.month)}-${__pad(__x.day)}`;\n const __time_string = (__x) => `${__pad(__x.hour)}:${__pad(__x.minute)}:${__pad(__x.second || 0)}`;\n const __datetime_string = (__x) => `${__pad(__x.year, 4)}-${__pad(__x.month)}-${__pad(__x.day)}T${__pad(__x.hour || 0)}:${__pad(__x.minute || 0)}:${__pad(__x.second || 0)}`;\n const __kind = (__x) => (__x && __x.__gregor) || (__x instanceof Date ? 'js-date' : false);\n const __get = (__x, __field) => { if (__x instanceof Date) { const __m = {year: __x.getFullYear(), month: __x.getMonth() + 1, day: __x.getDate(), hour: __x.getHours(), minute: __x.getMinutes(), second: __x.getSeconds()}; return __m[__field]; } return __x[__field]; };\n return __rkt_body({date: __date, time: __time, datetime: __datetime, parseDate: __parse_date, parseTime: __parse_time, parseDateTime: __parse_datetime, fromJSDate: __from_js_date, toJSDate: __to_js_date, dateString: __date_string, timeString: __time_string, dateTimeString: __datetime_string, kind: __kind, get: __get});\n})((__g) => ~a)" expr)) - - (define (compile-gregor op args) - (define lname (identifier-local-name op)) - (define (one who) (match args [(list x) x] [_ (fail who args)])) - (define (one/two who) (match args [(list x) x] [(list x _fmt) x] [_ (fail who args)])) - (define (date3 who) - (match args [(list y m d) (inline-gregor-runtime (format "__g.date(~a, ~a, ~a)" (compile-expr y) (compile-expr m) (compile-expr d)))] [_ (fail who args)])) - (define (time2/3 who) - (match args - [(list h m) (inline-gregor-runtime (format "__g.time(~a, ~a, 0)" (compile-expr h) (compile-expr m)))] - [(list h m s) (inline-gregor-runtime (format "__g.time(~a, ~a, ~a)" (compile-expr h) (compile-expr m) (compile-expr s)))] - [_ (fail who args)])) - (define (dt who) - (match args - [(list y mo d h mi) (inline-gregor-runtime (format "__g.datetime(~a, ~a, ~a, ~a, ~a, 0)" (compile-expr y) (compile-expr mo) (compile-expr d) (compile-expr h) (compile-expr mi)))] - [(list y mo d h mi s) (inline-gregor-runtime (format "__g.datetime(~a, ~a, ~a, ~a, ~a, ~a)" (compile-expr y) (compile-expr mo) (compile-expr d) (compile-expr h) (compile-expr mi) (compile-expr s)))] - [_ (fail who args)])) - (case (string->symbol lname) - [(string->date parse-date) (inline-gregor-runtime (format "__g.parseDate(~a)" (compile-expr (one/two op))))] - [(date->string) (inline-gregor-runtime (format "__g.dateString(~a)" (compile-expr (one op))))] - [(string->time parse-time) (inline-gregor-runtime (format "__g.parseTime(~a)" (compile-expr (one/two op))))] - [(time->string) (inline-gregor-runtime (format "__g.timeString(~a)" (compile-expr (one op))))] - [(string->datetime parse-moment parse-datetime) (inline-gregor-runtime (format "__g.parseDateTime(~a)" (compile-expr (one/two op))))] - [(datetime->string moment->string) (inline-gregor-runtime (format "__g.dateTimeString(~a)" (compile-expr (one op))))] - [(date make-date) (date3 op)] - [(time make-time) (time2/3 op)] - [(datetime moment make-datetime make-moment) (dt op)] - [(date?) (inline-gregor-runtime (format "(__g.kind(~a) === 'date')" (compile-expr (one op))))] - [(time?) (inline-gregor-runtime (format "(__g.kind(~a) === 'time')" (compile-expr (one op))))] - [(datetime? moment?) (inline-gregor-runtime (format "(__g.kind(~a) === 'datetime' || __g.kind(~a) === 'js-date')" (compile-expr (one op)) (compile-expr (one op))))] - [(->year year) (inline-gregor-runtime (format "__g.get(~a, 'year')" (compile-expr (one op))))] - [(->month month) (inline-gregor-runtime (format "__g.get(~a, 'month')" (compile-expr (one op))))] - [(->day day) (inline-gregor-runtime (format "__g.get(~a, 'day')" (compile-expr (one op))))] - [(->hours hours) (inline-gregor-runtime (format "__g.get(~a, 'hour')" (compile-expr (one op))))] - [(->minutes minutes) (inline-gregor-runtime (format "__g.get(~a, 'minute')" (compile-expr (one op))))] - [(->seconds seconds) (inline-gregor-runtime (format "__g.get(~a, 'second')" (compile-expr (one op))))] - [(->js-date) (inline-gregor-runtime (format "__g.toJSDate(~a)" (compile-expr (one op))))] - [(js-date->datetime) (inline-gregor-runtime (format "__g.fromJSDate(~a)" (compile-expr (one op))))] - [else #f])) - - (define (compile-division args) - ;; JavaScript produces Infinity for 10 / 0, while Racket raises an - ;; exception for exact division by zero. This subset uses a runtime - ;; zero-check so with-handlers can catch the common division-by-zero case. - (when (null? args) (fail "empty / operator" args)) - (define temps (for/list ([_ (in-list args)]) (fresh "div"))) - (define bindings - (for/list ([tmp (in-list temps)] [arg (in-list args)]) - (format "const ~a = ~a;" tmp (compile-expr arg)))) - (define denominators (if (= (length temps) 1) temps (cdr temps))) - (define checks - (for/list ([tmp (in-list denominators)]) - (format "if (~a === 0) throw new Error(\"division by zero\");" tmp))) - (define result - (if (= (length temps) 1) - (format "(1 / ~a)" (car temps)) - (parens (string-join temps " / ")))) - (format "(() => ~a)()" - (block (join-lines (append bindings checks (list (format "return ~a;" result))))))) - - (define (compile-operator op args) - (or (compile-gregor op args) - (let () - (define (binary jsop [empty #f] [single-prefix #f]) - (cond - [(null? args) (or empty (fail "empty operator" op))] - [(and (= (length args) 1) single-prefix) (format "(~a~a)" single-prefix (compile-expr (car args)))] - [else (parens (string-join (map compile-expr args) (format " ~a " jsop)))])) - (case op - [(+) (if (null? args) "0" (binary "+"))] - [(*) (if (null? args) "1" (binary "*"))] - [(-) (binary "-" #f "-")] - [(/) (compile-division args)] - [(quotient) (format "Math.trunc(~a / ~a)" (compile-expr (car args)) (compile-expr (cadr args)))] - [(remainder modulo) (binary "%")] - [(add1) (format "(~a + 1)" (compile-expr (car args)))] - [(sub1) (format "(~a - 1)" (compile-expr (car args)))] - [(abs) (format "Math.abs(~a)" (compile-expr (car args)))] - [(floor) (format "Math.floor(~a)" (compile-expr (car args)))] - [(ceiling) (format "Math.ceil(~a)" (compile-expr (car args)))] - [(round) (format "Math.round(~a)" (compile-expr (car args)))] - [(max) (format "Math.max(~a)" (string-join (map compile-expr args) ", "))] - [(min) (format "Math.min(~a)" (string-join (map compile-expr args) ", "))] - [(sqrt) (format "Math.sqrt(~a)" (compile-expr (car args)))] - [(sqr) (format "((__x) => __x * __x)(~a)" (compile-expr (car args)))] - [(expt) (format "Math.pow(~a, ~a)" (compile-expr (car args)) (compile-expr (cadr args)))] - [(sin cos tan asin acos atan log exp) (format "Math.~a(~a)" (symbol->string op) (string-join (map compile-expr args) ", "))] - [(zero?) (format "(~a === 0)" (compile-expr (car args)))] - [(positive?) (format "(~a > 0)" (compile-expr (car args)))] - [(negative?) (format "(~a < 0)" (compile-expr (car args)))] - [(even?) (format "(~a % 2 === 0)" (compile-expr (car args)))] - [(odd?) (format "(~a % 2 !== 0)" (compile-expr (car args)))] - [(= ==) (compile-comparison "===" args)] - [(equal?) (compile-deep-equal args)] - [(eq? eqv?) (compile-object-is args)] - [(!= not-equal?) (format "!(~a)" (compile-deep-equal args))] - [(< > <= >=) (compile-comparison (symbol->string op) args)] - [(and) (compile-and args)] - [(or) (compile-or args)] - [(not) (format "(~a === false)" (compile-expr (car args)))] - [(list vector) (format "[~a]" (string-join (map compile-expr args) ", "))] - [(list*) - (cond - [(null? args) "[]"] - [(null? (cdr args)) (compile-expr (car args))] - [else - (define fixed (reverse (cdr (reverse args)))) - (define last-arg (car (reverse args))) - (format "[~a].concat(~a)" (string-join (map compile-expr fixed) ", ") (compile-expr last-arg))])] - [(cons) (format "[~a].concat(~a)" (compile-expr (car args)) (compile-expr (cadr args)))] - [(append) (if (null? args) "[]" (format "[].concat(~a)" (string-join (map compile-expr args) ", ")))] - [(car first) (format "~a[0]" (parens (compile-expr (car args))))] - [(cdr rest) (format "~a.slice(1)" (parens (compile-expr (car args))))] - [(cadr second) (format "~a[1]" (parens (compile-expr (car args))))] - [(caddr third) (format "~a[2]" (parens (compile-expr (car args))))] - [(length vector-length string-length) (format "~a.length" (parens (compile-expr (car args))))] - [(list-ref vector-ref string-ref) (format "~a[~a]" (parens (compile-expr (car args))) (compile-expr (cadr args)))] - [(list-tail) (format "~a.slice(~a)" (parens (compile-expr (car args))) (compile-expr (cadr args)))] - [(last) (format "((__xs) => __xs[__xs.length - 1])(~a)" (compile-expr (car args)))] - [(list-set) - (match args - [(list xs i v) - (format "((__xs, __i, __v) => { const __out = __xs.slice(); __out[__i] = __v; return __out; })(~a, ~a, ~a)" - (compile-expr xs) (compile-expr i) (compile-expr v))] - [_ (fail "list-set" args)])] - [(list-update) - (match args - [(list xs i f) - (format "((__xs, __i, __f) => { const __out = __xs.slice(); __out[__i] = __f(__out[__i]); return __out; })(~a, ~a, ~a)" - (compile-expr xs) (compile-expr i) (compile-expr f))] - [_ (fail "list-update" args)])] - [(null? empty?) (format "((__xs) => Array.isArray(__xs) && __xs.length === 0)(~a)" (compile-expr (car args)))] - [(pair?) (format "((__xs) => Array.isArray(__xs) && __xs.length > 0)(~a)" (compile-expr (car args)))] - [(list? vector?) (format "Array.isArray(~a)" (compile-expr (car args)))] - [(number? real? integer?) (format "typeof ~a === \"number\"" (compile-expr (car args)))] - [(string?) (format "typeof ~a === \"string\"" (compile-expr (car args)))] - [(boolean?) (format "typeof ~a === \"boolean\"" (compile-expr (car args)))] - [(symbol?) (format "typeof ~a === \"string\"" (compile-expr (car args)))] - [(void) "undefined"] - [(values) (if (= (length args) 1) (compile-expr (car args)) (format "[~a]" (string-join (map compile-expr args) ", ")))] - [(string-append) (if (null? args) "\"\"" (binary "+"))] - [(substring) - (match args - [(list s start) (format "~a.substring(~a)" (parens (compile-expr s)) (compile-expr start))] - [(list s start end) (format "~a.substring(~a, ~a)" (parens (compile-expr s)) (compile-expr start) (compile-expr end))] - [_ (fail "substring" args)])] - [(string-upcase) (format "~a.toUpperCase()" (parens (compile-expr (car args))))] - [(string-downcase) (format "~a.toLowerCase()" (parens (compile-expr (car args))))] - [(string-trim) (format "~a.trim()" (parens (compile-expr (car args))))] - [(string-contains?) (format "~a.includes(~a)" (parens (compile-expr (car args))) (compile-expr (cadr args)))] - [(regexp? pregexp?) (format "(~a instanceof RegExp || typeof ~a === \"string\")" (compile-expr (car args)) (compile-expr (car args)))] - [(regexp-match) (compile-regexp-match args)] - [(regexp-match?) (compile-regexp-match? args)] - [(regexp-match*) (compile-regexp-match* args)] - [(regexp-match-positions) (compile-regexp-match-positions args)] - [(regexp-split) (compile-regexp-split args)] - [(regexp-replace) (compile-regexp-replace args #:all? #f)] - [(regexp-replace*) (compile-regexp-replace args #:all? #t)] - [(regexp-quote) (compile-regexp-quote args)] - [(string=? string-ci=?) (compile-comparison "===" args)] - [(string? string<=? string>=?) - (compile-comparison (case op [(string?) ">"] [(string<=?) "<="] [(string>=?) ">="]) args)] - [(number->string symbol->string string->symbol) (format "String(~a)" (compile-expr (car args)))] - [(string->number) (format "Number(~a)" (compile-expr (car args)))] - [(displayln) (format "console.log(~a)" (string-join (map compile-expr args) ", "))] - [(display) (format "console.log(~a)" (string-join (map compile-expr args) ", "))] - [(hash hasheq hasheqv) (compile-hash args)] - [(make-hash make-immutable-hash make-hasheq make-immutable-hasheq make-hasheqv make-immutable-hasheqv) - (compile-make-hash args)] - [(hash?) (format "((__h) => __h !== null && typeof __h === 'object' && !Array.isArray(__h))(~a)" (compile-expr (car args)))] - [(hash-ref) (compile-hash-ref args)] - [(hash-set) (compile-hash-set args)] - [(hash-set!) (compile-hash-set args #:mutate? #t)] - [(hash-remove) (compile-hash-remove args)] - [(hash-remove!) (compile-hash-remove args #:mutate? #t)] - [(hash-update) (compile-hash-update args)] - [(hash-update!) (compile-hash-update args #:mutate? #t)] - [(hash-clear) (compile-hash-clear args)] - [(hash-clear!) (compile-hash-clear args #:mutate? #t)] - [(hash-copy) (format "Object.assign({}, ~a)" (compile-expr (car args)))] - [(hash-copy-clear) "{}"] - [(hash-has-key?) (format "Object.prototype.hasOwnProperty.call(~a, ~a)" (compile-expr (car args)) (compile-expr (cadr args)))] - [(hash-count) (format "Object.keys(~a).length" (compile-expr (car args)))] - [(hash-empty?) (format "Object.keys(~a).length === 0" (compile-expr (car args)))] - [(hash-keys) (format "Object.keys(~a)" (compile-expr (car args)))] - [(hash-values) (format "Object.values(~a)" (compile-expr (car args)))] - [(hash->list) (format "Object.entries(~a)" (compile-expr (car args)))] - [(hash-map) (format "Object.entries(~a).map(([__k, __v]) => ~a(__k, __v))" (compile-expr (car args)) (compile-expr (cadr args)))] - [(hash-for-each) (format "((__h, __f) => { Object.entries(__h).forEach(([__k, __v]) => __f(__k, __v)); return undefined; })(~a, ~a)" (compile-expr (car args)) (compile-expr (cadr args)))] - [(reverse) (format "[...~a].reverse()" (parens (compile-expr (car args))))] - [(take) (format "~a.slice(0, ~a)" (parens (compile-expr (car args))) (compile-expr (cadr args)))] - [(drop) (format "~a.slice(~a)" (parens (compile-expr (car args))) (compile-expr (cadr args)))] - [(take-right) (format "((__xs, __n) => __xs.slice(Math.max(0, __xs.length - __n)))(~a, ~a)" (compile-expr (car args)) (compile-expr (cadr args)))] - [(drop-right) (format "((__xs, __n) => __xs.slice(0, Math.max(0, __xs.length - __n)))(~a, ~a)" (compile-expr (car args)) (compile-expr (cadr args)))] - [(member) - (format "((__v, __xs) => { const __i = __xs.findIndex((__x) => Object.is(__x, __v) || JSON.stringify(__x) === JSON.stringify(__v)); return __i < 0 ? false : __xs.slice(__i); })(~a, ~a)" - (compile-expr (car args)) (compile-expr (cadr args)))] - [(memq memv) - (format "((__v, __xs) => { const __i = __xs.findIndex((__x) => Object.is(__x, __v)); return __i < 0 ? false : __xs.slice(__i); })(~a, ~a)" - (compile-expr (car args)) (compile-expr (cadr args)))] - [(remove) - (format "((__v, __xs) => { let __done = false; return __xs.filter((__x) => { const __same = Object.is(__x, __v) || JSON.stringify(__x) === JSON.stringify(__v); if (!__done && __same) { __done = true; return false; } return true; }); })(~a, ~a)" - (compile-expr (car args)) (compile-expr (cadr args)))] - [(remove*) - (format "((__vs, __xs) => __xs.filter((__x) => !__vs.some((__v) => Object.is(__x, __v) || JSON.stringify(__x) === JSON.stringify(__v))))(~a, ~a)" - (compile-expr (car args)) (compile-expr (cadr args)))] - [(sort) - (match args - [(list xs less?) - (format "((__xs, __less) => __xs.slice().sort((__a, __b) => __less(__a, __b) !== false ? -1 : (__less(__b, __a) !== false ? 1 : 0)))(~a, ~a)" - (compile-expr xs) (compile-expr less?))] - [_ (fail "sort" args)])] - [(map) - (match args - [(list f xs) (format "~a.map((__x) => ~a(__x))" (parens (compile-expr xs)) (compile-expr f))] - [(list f xs more ...) - (format "((__arrays) => __arrays[0].map((_, __i) => ~a(...__arrays.map((__a) => __a[__i]))))([~a])" - (compile-expr f) (string-join (map compile-expr (cons xs more)) ", "))] - [_ (fail "map" args)])] - [(filter) (format "~a.filter((__x) => (~a(__x) !== false))" (parens (compile-expr (cadr args))) (compile-expr (car args)))] - [(foldl) (format "~a.reduce((__acc, __x) => ~a(__x, __acc), ~a)" (parens (compile-expr (caddr args))) (compile-expr (car args)) (compile-expr (cadr args)))] - [(foldr) (format "~a.reduceRight((__acc, __x) => ~a(__x, __acc), ~a)" (parens (compile-expr (caddr args))) (compile-expr (car args)) (compile-expr (cadr args)))] - [(apply) - (match args - [(list f last-arg) (format "~a(...~a)" (compile-expr f) (compile-expr last-arg))] - [(list f fixed ... last-arg) (format "~a(~a, ...~a)" (compile-expr f) (string-join (map compile-expr fixed) ", ") (compile-expr last-arg))] - [_ (fail "apply" args)])] - [(error) (format "(() => { throw new Error(~a); })()" (if (null? args) "\"error\"" (compile-expr (car args))))] - [(raise) (format "(() => { throw ~a; })()" (if (null? args) "new Error(\"raise\")" (compile-expr (car args))))] - [(exn?) (if (null? args) "true" "true")] - [(exn-message) (format "String((~a && ~a.message !== undefined) ? ~a.message : ~a)" (compile-expr (car args)) (compile-expr (car args)) (compile-expr (car args)) (compile-expr (car args)))] - [else #f])))) - - (define (compile-call f args) - (or (and (symbol? f) (compile-operator f args)) - (match f - ['send (match args - [(list obj method more ...) - (format "~a.~a(~a)" (compile-expr obj) (prop->js method) (string-join (map compile-expr more) ", "))] - [_ (fail "send" args)])] - ['new (match args - [(list cls more ...) (format "new ~a(~a)" (compile-expr cls) (string-join (map compile-expr more) ", "))] - [_ (fail "new" args)])] - ['js-ref (match args - [(list obj key) (format "~a[~a]" (compile-expr obj) (compile-expr key))] - [_ (fail "js-ref" args)])] - ['js-dot (match args - [(list obj (? symbol? key)) (format "~a.~a" (compile-expr obj) (prop->js key))] - [_ (fail "js-dot" args)])] - ['js-delete (match args - [(list obj key) (parens (compile-delete-target obj key))] - [_ (fail "js-delete" args)])] - ['array (format "[~a]" (string-join (map compile-expr args) ", "))] - ['object (compile-hash args)] - [_ (format "~a(~a)" (compile-callee f) (string-join (map compile-expr args) ", "))]))) - - (define (compile-expr d) - (match d - [(? boolean?) (if d "true" "false")] - [(? regexp?) (compile-regexp-literal d)] - [(? byte-regexp?) (fail "byte regexp literal" d)] - [(? number?) (number->string d)] - [(? string?) (js-string d)] - [(? char?) (js-string (string d))] - [(? keyword?) (js-string (keyword->string d))] - ['js-null "null"] - ['js-undefined "undefined"] - ['js-NaN "NaN"] - [(? symbol?) (id->js d)] - [(list 'quote v) (literal->js v)] - [(list 'quasiquote v) (literal->js v)] - [(list 'lambda formals body ...) - (format "function(~a) ~a" (compile-formals formals) (block (compile-body body #:return-last? #t)))] - [(list 'λ formals body ...) - (format "function(~a) ~a" (compile-formals formals) (block (compile-body body #:return-last? #t)))] - [(list 'if c t e) (compile-if-expr c t e)] - [(list 'begin es ...) (compile-begin-expr es)] - [(list 'while c body ...) - (format "(() => ~a)()" - (block (join-lines - (list (format "while (~a) ~a" (compile-test c) (block (compile-body body))) - "return undefined;"))))] - [(list 'begin0 first rest ...) - (define tmp "__begin0_value") - (format "(() => ~a)()" (block (join-lines (append (list (format "const ~a = ~a;" tmp (compile-expr first))) - (map compile-stmt rest) - (list (format "return ~a;" tmp))))))] - [(list 'let name bindings body ...) #:when (symbol? name) - (compile-named-let name bindings body #:return-last? #t #:as-expression? #t)] - [(list 'let bindings body ...) - (compile-let 'let bindings body #:return-last? #t #:as-expression? #t)] - [(list 'let* bindings body ...) - (compile-let 'let* bindings body #:return-last? #t #:as-expression? #t)] - [(list 'letrec bindings body ...) - (compile-let 'letrec bindings body #:return-last? #t #:as-expression? #t)] - [(list 'let-values bindings body ...) - (compile-let-values 'let-values bindings body #:return-last? #t #:as-expression? #t)] - [(list 'let*-values bindings body ...) - (compile-let-values 'let*-values bindings body #:return-last? #t #:as-expression? #t)] - [(list 'cond clauses ...) - (format "(() => ~a)()" (block (compile-cond clauses #:return-last? #t)))] - [(list 'case key clauses ...) - (format "(() => ~a)()" (block (compile-case key clauses #:return-last? #t)))] - [(list 'with-handlers clauses body ...) - (compile-with-handlers clauses body #:return-last? #t #:as-expression? #t)] - [(list 'for/list clauses body ...) - (compile-for clauses body #:collect? #t #:as-expression? #t)] - [(list 'for/vector clauses body ...) - (compile-for clauses body #:collect? #t #:as-expression? #t)] - [(list 'for clauses body ...) - (compile-for clauses body #:collect? #f #:as-expression? #t)] - [(list 'for/fold bindings clauses body ...) - (compile-for-fold bindings clauses body)] - [(list 'when c body ...) - (format "(() => ~a)()" (block (compile-return `(when ,c ,@body))))] - [(list 'unless c body ...) - (format "(() => ~a)()" (block (compile-return `(unless ,c ,@body))))] - [(list 'let-object bindings obj body ...) - (compile-let-object bindings obj body #:return-last? #t #:as-expression? #t)] - [(list 'js-delete obj key) - (parens (compile-delete-target obj key))] - [(list 'set-prop! obj key val) - (format "(~a[~a] = ~a)" (compile-expr obj) (compile-expr key) (compile-expr val))] - [(list 'set! obj (? dot-prop-symbol? prop) rhs) - (format "(~a.~a = ~a)" (compile-expr obj) (dot-prop->js prop) (compile-expr rhs))] - [(list 'set! target rhs) - (format "(~a = ~a)" (compile-assignment-target target) (compile-expr rhs))] - [(list 'return) "undefined"] - [(list 'return e) (compile-expr e)] - [(list 'inject racket-expr) - (compile-racket-eval racket-expr)] - [(list 'eval racket-expr) - (compile-racket-eval racket-expr)] - [(list f args ...) (compile-call f args)] - [_ (literal->js d)])) - - (define (compile-top forms) - ;; A js form produces JavaScript program/statement text. It must be valid - ;; when handed directly to a WebView run/evaluateJavaScript entry point, so - ;; it may not invent top-level return statements. Return insertion still - ;; happens in expression contexts and function bodies, where JavaScript - ;; return is syntactically valid. - (compile-body forms #:return-last? #f))) - -(define-syntax (js stx) + (for-syntax racket/base)) + +(provide js js1) + +;; A deliberately small Racket/Scheme-to-JavaScript string maker. +;; +;; Design notes: +;; - This is still a macro based string generator, not a full compiler. +;; - `let` and `let*` are kept distinct: ordinary `let` evaluates all RHS +;; expressions before introducing the bound names; `let*` binds sequentially. +;; - named `let` is compiled as a JavaScript `while (true)` loop. A tail call +;; to the named-let identifier is rewritten to parallel assignments plus +;; `continue`. Other tail statements fall through with `break` so the loop +;; cannot accidentally become infinite. + +;; ------------------------------------------------------------------------- +;; Runtime helpers used by the generated macro expansion. +;; ------------------------------------------------------------------------- + +(define (symbol->js-name s) + (define str (symbol->string s)) + (define cleaned (regexp-replace* #px"[^A-Za-z0-9_.$]" str "_")) + (cond [(regexp-match? #px"^[A-Za-z_$]" cleaned) cleaned] + [else (string-append "_" cleaned)])) + +(define (js-escape-string s) + (apply string-append + (for/list ([ch (in-string s)]) + (case ch + [(#\\) "\\\\"] + [(#\") "\\\""] + [(#\newline) "\\n"] + [(#\return) "\\r"] + [(#\tab) "\\t"] + [else (string ch)])))) + +(define (js-string s) + (string-append "\"" (js-escape-string (format "~a" s)) "\"")) + +(define (js-number n) + (cond [(and (real? n) (not (integer? n))) (number->string (exact->inexact n))] + [else (format "~a" n)])) + +(define (js-datum v) + (cond [(string? v) (js-string v)] + [(symbol? v) (js-string (symbol->string v))] + [(number? v) (js-number v)] + [(boolean? v) (if v "true" "false")] + [(null? v) "[]"] + [(list? v) (string-append "[" (string-join (map js-datum v) ", ") "]")] + [else (error 'js-datum "unsupported datum: ~e" v)])) + +(define (js-stmt s) + (define t (string-trim s)) + (cond [(equal? t "") ""] + [(or (string-suffix? t ";") + (string-suffix? t "}") + (string-suffix? t ")")) ; IIFE or function call expression may still need ; + (if (string-suffix? t ")") (string-append s ";\n") (string-append s "\n"))] + [else (string-append s ";\n")])) + +(define (js-block body) + (string-append "{\n" body "}\n")) + +;; ------------------------------------------------------------------------- +;; Small string-making macros. +;; ------------------------------------------------------------------------- + +(define-syntax js-primitive + (syntax-rules () + [(_ a) (js-datum 'a)])) + +(define-syntax js-id + (syntax-rules () + [(_ a) (symbol->js-name 'a)])) + +(define-syntax js-ids + (syntax-rules () + [(_ a ...) (string-join (list (js-id a) ...) ", ")])) + +(define-syntax js-join + (syntax-rules () + [(_ sep (a ...)) (string-join (list (js1 a) ...) sep)])) + +(define-syntax js-infix + (syntax-rules () + [(_ sep (a ...)) (string-join (list (js1 a) ...) sep)])) + +(define-syntax js-call + (syntax-rules () + [(_ f) (string-append (js-id f) "()")] + [(_ f a ...) (string-append (js-id f) "(" (js-join ", " (a ...)) ")")])) + +(define-syntax js-array + (syntax-rules () + [(_) "[]"] + [(_ a ...) (string-append "[" (js-join ", " (a ...)) "]")])) + +(define-syntax js-cons + (syntax-rules () + [(_ a b) (string-append "[" (js1 a) "].concat(" (js1 b) ")")])) + +(define-syntax js-dot* + (syntax-rules () + [(_ obj field) (string-append (js1 obj) "." (js-id field))] + [(_ obj field rest ...) (js-dot* (js-dot* obj field) rest ...)])) + +(define-syntax js-send + (syntax-rules () + [(_ obj method) (string-append (js1 obj) "." (js-id method) "()")] + [(_ obj method arg ...) (string-append (js1 obj) "." (js-id method) "(" (js-join ", " (arg ...)) ")")])) + +(define-syntax js-new + (syntax-rules () + [(_ class) (string-append "new " (js-id class) "()")] + [(_ class arg ...) (string-append "new " (js-id class) "(" (js-join ", " (arg ...)) ")")])) + +(define-syntax js-set! + (syntax-rules () + [(_ target expr) (string-append (js1 target) " = " (js1 expr) ";")])) + +(define-syntax js-return + (syntax-rules () + [(_ expr) (string-append "return " (js1 expr) ";")])) + +(define-syntax js-begin + (syntax-rules () + [(_ body ...) (js-block (js body ...))])) + +(define-syntax js-if + (syntax-rules () + [(_ c then else) + (string-append "if (" (js1 c) ") {\n" + (js-stmt (js1 then)) + "} else {\n" + (js-stmt (js1 else)) + "}")])) + +(define-syntax js-define-function + (syntax-rules () + [(_ f (arg ...) body ...) + (string-append "function " (js-id f) "(" (js-ids arg ...) ") {\n" + (js body ...) + "}")])) + +(define-syntax js-define-value + (syntax-rules () + [(_ name expr) (string-append "let " (js-id name) " = " (js1 expr) ";")])) + +(define-syntax js-lambda + (syntax-rules () + [(_ (arg ...) body ...) + (string-append "function (" (js-ids arg ...) ") {\n" + (js body ...) + "}")])) + +(define-syntax js-let* + (syntax-rules () + [(_ ([id init] ...) body ...) + (string-append "{\n" + (string-append "let " (js-id id) " = " (js1 init) ";\n") ... + (js body ...) + "}")])) + +(define-syntax (js-let stx) (syntax-case stx () - [(_ form ...) - (let-values ([(clean-datum evals) (replace-racket-evals #'(form ...))]) - (wrap-compiled-js stx (compile-top clean-datum) evals))])) + [(_ ([id init] ...) body ...) + (with-syntax ([(tmp ...) (generate-temporaries #'(id ...))]) + #'(string-append "{\n" + ;; First evaluate all RHS expressions into temporary names. + ;; This preserves ordinary Racket/Scheme `let` scoping: + ;; newly bound names are not visible to other RHS expressions. + (string-append "const " (js-id tmp) " = " (js1 init) ";\n") ... + (string-append "let " (js-id id) " = " (js-id tmp) ";\n") ... + (js body ...) + "}"))])) -(define-syntax (js/expression stx) +;; ------------------------------------------------------------------------- +;; named-let loop support. +;; ------------------------------------------------------------------------- + +(define-for-syntax (same-length? a b) + (= (length (syntax->list a)) (length (syntax->list b)))) + +(define-syntax (js-loop-continue stx) (syntax-case stx () - [(_ form) - (let-values ([(clean-datum evals) (replace-racket-evals #'form)]) - (wrap-compiled-js stx (compile-expr clean-datum) evals))])) + [(_ (var ...) (arg ...)) + (unless (same-length? #'(var ...) #'(arg ...)) + (raise-syntax-error 'js-loop-continue "named let tail call has the wrong arity" stx)) + (with-syntax ([(tmp ...) (generate-temporaries #'(var ...))]) + #'(string-append + ;; Evaluate new values before assigning loop variables, so the update + ;; is parallel, not sequential. + (string-append "const " (js-id tmp) " = " (js1 arg) ";\n") ... + (string-append (js-id var) " = " (js-id tmp) ";\n") ... + "continue;\n"))])) + +(define-syntax (js-loop-tail stx) + (syntax-case stx () + ;; More than one expression in tail position: emit the leading statement, + ;; then continue tail conversion on the rest. + [(_ loop-name (var ...) first second rest ...) + #'(string-append (js-stmt (js1 first)) + (js-loop-tail loop-name (var ...) second rest ...))] + + ;; One expression in tail position. + [(_ loop-name (var ...) expr) + (syntax-case #'expr (if begin return) + [(if c then else) + #'(string-append "if (" (js1 c) ") {\n" + (js-loop-tail loop-name (var ...) then) + "} else {\n" + (js-loop-tail loop-name (var ...) else) + "}\n")] + [(begin body ...) + #'(js-loop-tail loop-name (var ...) body ...)] + [(return value) + #'(string-append "return " (js1 value) ";\n")] + [(call arg ...) + (and (identifier? #'call) (free-identifier=? #'call #'loop-name)) + #'(js-loop-continue (var ...) (arg ...))] + [_ + ;; Statement-oriented fallback: execute the tail expression once and + ;; leave the loop. In normal use, a named-let body ends in either a + ;; loop tail call or an explicit return/breaking condition. + #'(string-append (js-stmt (js1 expr)) "break;\n")])])) + +(define-syntax (js-named-let stx) + (syntax-case stx () + [(_ loop-name ([id init] ...) body ...) + (with-syntax ([(tmp ...) (generate-temporaries #'(id ...))]) + #'(string-append "{\n" + ;; Initial expressions are evaluated before the loop + ;; variables are introduced, like named `let` in Racket. + (string-append "const " (js-id tmp) " = " (js1 init) ";\n") ... + (string-append "let " (js-id id) " = " (js-id tmp) ";\n") ... + "while (true) {\n" + (js-loop-tail loop-name (id ...) body ...) + "}\n" + "}"))])) + +;; ------------------------------------------------------------------------- +;; Main dispatcher. This is intentionally normalized by syntactic form first, +;; instead of by arity first. +;; ------------------------------------------------------------------------- + +(define-syntax (js1 stx) + (syntax-case stx () + [(_ (define (f arg ...) body ...)) #'(js-define-function f (arg ...) body ...)] + [(_ (define name expr)) #'(js-define-value name expr)] + [(_ (lambda (arg ...) body ...)) #'(js-lambda (arg ...) body ...)] + [(_ (λ (arg ...) body ...)) #'(js-lambda (arg ...) body ...)] + [(_ (if c then else)) #'(js-if c then else)] + [(_ (set! target expr)) #'(js-set! target expr)] + [(_ (let loop-name ([id init] ...) body ...)) + (identifier? #'loop-name) + #'(js-named-let loop-name ([id init] ...) body ...)] + [(_ (let ([id init] ...) body ...)) #'(js-let ([id init] ...) body ...)] + [(_ (let* ([id init] ...) body ...)) #'(js-let* ([id init] ...) body ...)] + [(_ (begin body ...)) #'(js-begin body ...)] + [(_ (return expr)) #'(js-return expr)] + [(_ (quote datum)) #'(js-datum 'datum)] + [(_ (eval expr)) #'(js-datum expr)] + + ;; Generic operator/function-call dispatch. + [(_ (op arg ...)) + (let ([d (syntax-e #'op)]) + (cond [(eq? d '+) #'(js-infix " + " (arg ...))] + [(eq? d '-) #'(js-infix " - " (arg ...))] + [(eq? d '*) #'(js-infix " * " (arg ...))] + [(eq? d '/) #'(js-infix " / " (arg ...))] + [(eq? d 'and) #'(js-infix " && " (arg ...))] + [(eq? d 'or) #'(js-infix " || " (arg ...))] + [(eq? d '>) #'(js-infix " > " (arg ...))] + [(eq? d '<) #'(js-infix " < " (arg ...))] + [(eq? d '>=) #'(js-infix " >= " (arg ...))] + [(eq? d '<=) #'(js-infix " <= " (arg ...))] + [(eq? d '==) #'(js-infix " == " (arg ...))] + [(eq? d '===) #'(js-infix " === " (arg ...))] + [(eq? d '!=) #'(js-infix " != " (arg ...))] + [(eq? d '!==) #'(js-infix " !== " (arg ...))] + [(eq? d 'not) #'(string-append "!(" (js1 arg ...) ")")] + [(eq? d 'send) #'(js-send arg ...)] + [(eq? d 'list) #'(js-array arg ...)] + [(eq? d 'cons) #'(js-cons arg ...)] + [(or (eq? d 'js-dot) (eq? d 'dot)) #'(js-dot* arg ...)] + [(eq? d 'new) #'(js-new arg ...)] + [(identifier? #'op) #'(js-call op arg ...)] + [else (raise-syntax-error 'js1 "unsupported compound expression" stx #'op)]))] + + [(_ a) + (cond [(identifier? #'a) #'(symbol->js-name 'a)] + [else #'(js-datum 'a)])])) + +(define-syntax js + (syntax-rules () + [(_ statement ...) + (string-append (js-stmt (js1 statement)) ...)])) + +;; ------------------------------------------------------------------------- +;; Examples +;; ------------------------------------------------------------------------- + +#| +(js + (define (sum-to n) + (let loop ([i 0] [acc 0]) + (if (> i n) + (return acc) + (loop (+ i 1) (+ acc i)))))) + +=> +function sum_to(n) { +{ +const temp... = 0; +const temp... = 0; +let i = temp...; +let acc = temp...; +while (true) { +if (i > n) { +return acc; +} else { +const temp... = i + 1; +const temp... = acc + i; +i = temp...; +acc = temp...; +continue; +} +} +} +} +|#