1186 lines
61 KiB
Racket
1186 lines
61 KiB
Racket
#lang racket/base
|
|
|
|
(require (for-syntax racket/base
|
|
racket/list
|
|
racket/match
|
|
racket/string))
|
|
|
|
(provide js js/expression)
|
|
|
|
;; 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 (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))
|
|
|
|
;; 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)))]
|
|
[_ (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! 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)
|
|
;; Evaluate all RHS expressions before introducing the JS let bindings.
|
|
;; This avoids JavaScript TDZ bugs for Racket code such as
|
|
;; (let ([x x]) ...), where the RHS must see the outer x.
|
|
(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))))))))]
|
|
[(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 (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<=? string>=?
|
|
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) ", "))]
|
|
[(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)))]
|
|
[(null? empty?) (format "Array.isArray(~a) && ~a.length === 0" (compile-expr (car args)) (parens (compile-expr (car args))))]
|
|
[(pair?) (format "Array.isArray(~a) && ~a.length > 0" (compile-expr (car args)) (parens (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<=? string>=?)
|
|
(compile-comparison (case op [(string<?) "<"] [(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) (compile-hash args)]
|
|
[(hash-ref)
|
|
(match args
|
|
[(list h k) (format "~a[~a]" (parens (compile-expr h)) (compile-expr k))]
|
|
[(list h k default) (format "((__h, __k) => Object.prototype.hasOwnProperty.call(__h, __k) ? __h[__k] : ~a)(~a, ~a)" (compile-expr default) (compile-expr h) (compile-expr k))]
|
|
[_ (fail "hash-ref" args)])]
|
|
[(hash-set) (format "Object.assign({}, ~a, { [~a]: ~a })" (compile-expr (car args)) (compile-expr (cadr args)) (compile-expr (caddr args)))]
|
|
[(hash-has-key?) (format "Object.prototype.hasOwnProperty.call(~a, ~a)" (compile-expr (car args)) (compile-expr (cadr args)))]
|
|
[(hash-keys) (format "Object.keys(~a)" (compile-expr (car args)))]
|
|
[(hash-values) (format "Object.values(~a)" (compile-expr (car 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)))]
|
|
[(member memq memv) (format "~a.includes(~a)" (parens (compile-expr (cadr args))) (compile-expr (car 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! target rhs)
|
|
(format "(~a = ~a)" (compile-assignment-target target) (compile-expr rhs))]
|
|
[(list 'return) "undefined"]
|
|
[(list 'return e) (compile-expr e)]
|
|
[(list f args ...) (compile-call f args)]
|
|
[_ (literal->js d)]))
|
|
|
|
(define (compile-top forms)
|
|
(compile-body forms #:return-last? #f)))
|
|
|
|
(define-syntax (js stx)
|
|
(syntax-case stx ()
|
|
[(_ form ...)
|
|
(datum->syntax stx (compile-top (syntax->datum #'(form ...))))]))
|
|
|
|
(define-syntax (js/expression stx)
|
|
(syntax-case stx ()
|
|
[(_ form)
|
|
(datum->syntax stx (compile-expr (syntax->datum #'form)))]))
|