#lang scheme/base
(require (only-in srfi/1 drop-right take-right)
"../base.ss"
"op-util.ss"
"quote.ss"
"struct.ss")
(define (js:var . initializers)
(make-VariableDeclaration #f (map (lambda (arg)
(if (VariableInitializer? arg)
arg
(make-VariableInitializer #f (quote-identifier arg) #f)))
initializers)))
(define (js:init id [expr (void)])
(make-VariableInitializer #f (quote-identifier id) (if (void? expr) #f (quote-expression expr))))
(define (js:empty)
(make-EmptyStatement #f))
(define (js:begin . stmts)
(wrap-begin stmts))
(define (js:block . stmts)
(make-BlockStatement #f (map quote-javascript stmts)))
(define js:if
(case-lambda
[(test positive)
(make-IfStatement #f (quote-expression test) (wrap-block positive) #f)]
[(test positive negative)
(make-IfStatement #f (quote-expression test) (wrap-block (list positive)) (wrap-block (list negative)))]))
(define (js:do #:while expr . stmts)
(make-DoWhileStatement #f (wrap-block stmts) (quote-expression expr)))
(define (js:while expr . stmts)
(make-WhileStatement #f (quote-expression expr) (wrap-block stmts)))
(define (js:for #:init [init (void)] #:test [test (void)] #:incr [incr (void)] . stmts)
(make-ForStatement #f
(if (void? init) #f init)
(if (void? test) #f (quote-expression test))
(if (void? incr) #f (quote-expression incr))
(wrap-block stmts)))
(define (js:for-in var container . stmts)
(make-ForInStatement
#f
(cond [(VariableDeclaration? var)
(if (equal? (length (VariableDeclaration-bindings var)) 1)
var
(raise-exn exn:fail:contract
(format "for-in loops only support a single iterator variable: ~a" var)))]
[(Expression? var) var]
[(pair? var) (quote-identifier (car var))]
[else (quote-identifier var)])
(quote-expression container)
(wrap-block stmts)))
(define (js:break [label (void)])
(if (void? label)
(make-BreakStatement #f #f)
(make-BreakStatement #f (quote-identifier label))))
(define (js:continue [label (void)])
(if (void? label)
(make-ContinueStatement #f #f)
(make-ContinueStatement #f (quote-identifier label))))
(define (js:return [label (void)])
(if (void? label)
(make-ReturnStatement #f #f)
(make-ReturnStatement #f (quote-expression label))))
(define (js:with expr . stmts)
(make-WithStatement #f (quote-expression expr) (wrap-block stmts)))
(define (js:switch expr . clauses)
(make-SwitchStatement #f (quote-expression expr) clauses))
(define (js:case expr . stmts)
(make-CaseClause #f (quote-expression expr) stmts))
(define (js:default . stmts)
(make-CaseClause #f #f stmts))
(define (js:label id stmt)
(make-LabelledStatement #f (quote-identifier id) (quote-statement stmt)))
(define (js:throw expr)
(make-ThrowStatement #f (quote-expression expr)))
(define (js:try . stmts+clauses)
(make-TryStatement #f
(wrap-block (filter statement+quotable? stmts+clauses))
(filter CatchClause? stmts+clauses)))
(define (js:catch id . stmts)
(make-CatchClause #f (quote-identifier id) (wrap-block stmts)))
(define (js:finally . stmts)
(make-CatchClause #f #f (wrap-block stmts)))
(define (js:array . exprs)
(make-ArrayLiteral #f (map quote-expression exprs)))
(define (js:object . fields)
(make-ObjectLiteral #f fields))
(define (js:field index expr)
(cons (cond [(Identifier? index) index]
[(StringLiteral? index) index]
[(NumericLiteral? index) index]
[(symbol? index) (make-Identifier #f index)]
[(string? index) (make-StringLiteral #f index)]
[(integer? index) (make-NumericLiteral #f index)])
(quote-expression expr)))
(define (js:regexp value #:global? [global? #f] #:ci? [ci? #f])
(make-RegexpLiteral #f value global? ci?))
(define (js:index expr index)
(make-BracketReference #f (quote-expression expr) (quote-expression index)))
(define (js:dot . args)
(cond [(null? args) (error (format "js:dot: expected one or more arguments, received none."))]
[(null? (cdr args)) (error (format "js:dot: expected one or more arguments, received one: ~a." (car args)))]
[(null? (cddr args)) (make-DotReference #f (quote-expression (car args)) (quote-identifier (cadr args)))]
[else (let ([most (drop-right args 1)]
[last (car (take-right args 1))])
(make-DotReference #f (apply js:dot most) (quote-identifier last)))]))
(define (js:new constructor . args)
(make-NewExpression #f (quote-expression constructor) (map quote-expression args)))
(define-prefix-expr-constructors)
(define-postfix-expr-constructors)
(define-infix-expr-constructors)
(define-assignment-expr-constructors)
(define (js:function args . stmts)
(make-FunctionExpression #f #f (map quote-identifier args) (map quote-javascript stmts)))
(define (js:all . args)
(make-ListExpression #f (map quote-expression args)))
(define (js:call function . args)
(make-CallExpression #f (parenthesize-anonymous-function (quote-expression function)) (map quote-expression args)))
(define (js:id sym)
(make-Identifier #f sym))
(provide/contract
[rename js:var var (->* ((or/c identifier+quotable? VariableInitializer?)) () #:rest (listof (or/c identifier+quotable? VariableInitializer?)) VariableDeclaration?)]
[rename js:init init (->* (identifier+quotable?) (expression+quotable?) VariableInitializer?)]
[rename js:begin begin (->* () () #:rest (listof javascript+quotable?) SourceElement?)]
[rename js:block block (->* () () #:rest (listof javascript+quotable?) SourceElement?)]
[rename js:if if (->* (expression+quotable? statement+quotable?) (statement+quotable?) IfStatement?)]
[rename js:do do (->* (#:while expression+quotable?) () #:rest (listof statement+quotable?) DoWhileStatement?)]
[rename js:while while (->* (expression+quotable?) () #:rest (listof statement+quotable?) WhileStatement?)]
[rename js:for for (->* () (#:init (or/c VariableDeclaration? expression+quotable?) #:test expression+quotable? #:incr expression+quotable?) #:rest (listof statement+quotable?) ForStatement?)]
[rename js:for-in for-in (->* ((or/c VariableDeclaration? expression+quotable?) expression+quotable?) () #:rest (listof statement+quotable?) ForInStatement?)]
[rename js:break break (->* () (identifier+quotable?) BreakStatement?)]
[rename js:continue continue (->* () (identifier+quotable?) ContinueStatement?)]
[rename js:return return (->* () (expression+quotable?) ReturnStatement?)]
[rename js:with with (->* (expression+quotable?) () #:rest (listof statement+quotable?) WithStatement?)]
[rename js:switch switch (->* (expression+quotable?) () #:rest (listof CaseClause?) SwitchStatement?)]
[rename js:case case (->* (expression+quotable?) () #:rest (listof statement+quotable?) CaseClause?)]
[rename js:default default (->* () () #:rest (listof statement+quotable?) CaseClause?)]
[rename js:label label (->* (identifier+quotable? statement+quotable?) () LabelledStatement?)]
[rename js:throw throw (->* (expression+quotable?) () ThrowStatement?)]
[rename js:try try (->* () () #:rest (listof (or/c statement+quotable? CatchClause?)) TryStatement?)]
[rename js:catch catch (->* (identifier+quotable?) () #:rest (listof statement+quotable?) CatchClause?)]
[rename js:finally finally (->* () () #:rest (listof statement+quotable?) CatchClause?)]
[rename js:array array (->* () () #:rest (listof expression+quotable?) ArrayLiteral?)]
[rename js:object object (->* () () #:rest (listof (cons/c Property? expression+quotable?)) ObjectLiteral?)]
[rename js:field field (-> (or/c Identifier? StringLiteral? NumericLiteral? symbol? string? integer?)
expression+quotable?
(cons/c Property? Expression?))]
[rename js:index index (->* (expression+quotable? expression+quotable?) () BracketReference?)]
[rename js:regexp regexp (->* (string?) (#:global? boolean? #:ci? boolean?) RegexpLiteral?)]
[rename js:dot dot (->* (expression+quotable?) () #:rest (listof expression+quotable?) DotReference?)]
[rename js:new new (->* (expression+quotable?) () #:rest (listof expression+quotable?) NewExpression?)]
[rename js:function function (->* ((listof identifier+quotable?)) () #:rest (listof javascript+quotable?) FunctionExpression?)]
[rename js:all all (->* () () #:rest (listof expression+quotable?) ListExpression?)]
[rename js:call call (->* (expression+quotable?) () #:rest (listof expression+quotable?) CallExpression?)]
[rename js:id id (->* (symbol?) () Identifier?)])