#lang racket/base

(require racket/string
         (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 ()
    [(_ ([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 ...)
                        "}"))]))

;; -------------------------------------------------------------------------
;; 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 ()
    [(_ (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;
}
}
}
}
|#