(module javascript mzscheme
  (require (lib "plt-match.ss"))
  (require-for-syntax (lib "etc.ss")
                      (lib "list.ss")
                      (lib "plt-match.ss"))
  (require (planet "ast.ss" ("dherman" "javascript.plt" 2) "syntax")
           (planet "pretty-print.ss" ("dherman" "javascript.plt" 2) "syntax")
           (planet "parse.ss" ("dherman" "javascript.plt" 2) "syntax")
           (planet "token.ss" ("dherman" "javascript.plt" 2) "syntax"))
  (require-for-syntax (lib "to-string.ss" "syntax"))
  
  (define-for-syntax or-expand 
    (opt-lambda (kind [bt empty])
      (match-lambda*
        [(list)
         (lambda args
           (error 'or-expand "~a: No options:~n~a~nBacktrace: ~a"
                  kind
                  (map syntax->string args)
                  bt))]
        [(list-rest e es)
         (lambda args
           (with-handlers ([exn?
                            (lambda (exn)
                              (apply (apply (or-expand
                                             kind
                                             (list* (format "~a~n" (exn-message exn)) bt))
                                            es)
                                     args))])
             (apply e args)))])))
  
  (define (stx->region stx)
    (make-region (syntax-source stx)
                 (make-position (syntax-position stx)
                                (syntax-line stx)
                                (syntax-column stx))
                 (make-position (+ (syntax-span stx)
                                   (syntax-position stx))
                                (syntax-line stx)
                                (+ (syntax-span stx)
                                   (syntax-column stx)))))
  (define-for-syntax (stx->region stx)
    #`(stx->region #'#,stx))
  
  (define-syntax (javascript stx)
    ; Unquote
    (define (expand-unquote stx)
      (syntax-case stx (unquote unsyntax)
        [(unquote expr)
         #`(javascript-marshal expr)]
        [(unsyntax expr)
         #`expr]))
    ; Declarations
    (define (expand-FunctionDeclaration stx)
      (syntax-case stx (define)
        [(define (name arg ...) body ...)
         #`(make-FunctionDeclaration #,(stx->region stx)
                                     #,(expand-Identifier #`name)
                                     (list #,@(map expand-Identifier 
                                                   (syntax->list #`(arg ...))))
                                     (list #,@(map expand-SourceElement 
                                                   (syntax->list #`(body ...)))))]))
    (define (expand-VariableDeclaration stx)
      (syntax-case stx (define)
        [(define name)
         #`(make-VariableDeclaration #,(stx->region stx)
                                     (list (make-VariableInitializer
                                            #,(stx->region stx)
                                            #,(expand-Identifier #`name)
                                            #f)))]
        [(define name init)
         #`(make-VariableDeclaration #,(stx->region stx)
                                     (list (make-VariableInitializer
                                            #,(stx->region stx)
                                            #,(expand-Identifier #`name)
                                            #,(expand-Expression #`init))))]))
    (define expand-Declaration
      ((or-expand "Declaration")
       expand-unquote
       expand-FunctionDeclaration
       expand-VariableDeclaration))
    ; Literals
    (define (expand-StringLiteral stx)
      (match (syntax-object->datum stx)
        [(? string?)
         #`(make-StringLiteral #,(stx->region stx)
                               #,stx)]))
    (define (expand-NumericLiteral stx)
      (match (syntax-object->datum stx)
        [(? number?)
         #`(make-NumericLiteral #,(stx->region stx)
                                #,stx)]))
    (define (expand-BooleanLiteral stx)
      (match (syntax-object->datum stx)
        [(? boolean?)
         #`(make-BooleanLiteral #,(stx->region stx)
                                #,stx)]))
    (define (expand-NullLiteral stx)
      (syntax-case stx (null)
        [(null)
         #`(make-NullLiteral #,(stx->region stx))]))
    (define (expand-RegexpLiteral stx)
      (syntax-case stx (regexp)
        [(regexp pattern)
         #`(make-RegexpLiteral #,(stx->region stx)
                               pattern
                               #f #f)]
        [(regexp pattern global? case-insensitive?)
         #`(make-RegexpLiteral #,(stx->region stx)
                               pattern
                               global?
                               case-insensitive?)]))
    (define (expand-ArrayLiteral stx)
      (syntax-case stx (array)
        [(array expr ...)
         #`(make-ArrayLiteral #,(stx->region stx)
                              (list #,@(map expand-Expression 
                                            (syntax->list #`(expr ...)))))]))
    (define (expand-ObjectLiteral stx)
      (syntax-case stx (object)
        [(object (prop expr) ...)
         #`(make-ObjectLiteral #,(stx->region stx)
                               (list #,@(map (lambda (p e)
                                               #`(cons #,(expand-Property p)
                                                       #,(expand-Expression e)))
                                             (syntax->list #`(prop ...))
                                             (syntax->list #`(expr ...)))))]))
    ; References
    (define (expand-ThisReference stx)
      (syntax-case stx (this)
        [(this)
         #`(make-ThisReference #,(stx->region stx))]))
    (define (expand-VarReference stx)
      #`(make-VarReference #,(stx->region stx)
                           #,(expand-Identifier stx)))
    (define (expand-BracketReference stx)
      (syntax-case stx (array-ref)
        [(array-ref c k)
         #`(make-BracketReference #,(stx->region stx)
                                  #,(expand-Expression #`c)
                                  #,(expand-Expression #`k))]))
    (define (expand-DotReference stx)
      (syntax-case stx (dot)
        [(dot c i ...)
         (foldl (lambda (i a)
                  #`(make-DotReference #,(stx->region stx)
                                       #,a
                                       #,(expand-Identifier i)))
                (expand-Expression #`c)
                (syntax->list #`(i ...)))]))
    ; Expressions
    (define (expand-NewExpression stx)
      (syntax-case stx (new)
        [(new c arg ...)
         #`(make-NewExpression #,(stx->region stx)
                               #,(expand-Expression #`c)
                               (list #,@(map expand-Expression
                                             (syntax->list #`(arg ...)))))]))
    (define (expand-PostfixExpression stx)
      (syntax-case stx (++ --)
        [(expr ++)
         #`(make-PostfixExpression #,(stx->region stx)
                                   #,(expand-Expression #`expr)
                                   '++)]
        [(expr --)
         #`(make-PostfixExpression #,(stx->region stx)
                                   #,(expand-Expression #`expr)
                                   '--)]))
    (define (expand-PrefixExpression stx)
      (syntax-case stx (delete void typeof ++ -- + - ~ !)
        [(delete expr)
         #`(make-PrefixExpression #,(stx->region stx) #,(expand-Expression #`expr) 'delete)]
        [(void expr)
         #`(make-PrefixExpression #,(stx->region stx) #,(expand-Expression #`expr) 'void)]
        [(typeof expr)
         #`(make-PrefixExpression #,(stx->region stx) #,(expand-Expression #`expr) 'typeof)]
        [(++ expr)
         #`(make-PrefixExpression #,(stx->region stx) #,(expand-Expression #`expr) '++)]
        [(-- expr)
         #`(make-PrefixExpression #,(stx->region stx) #,(expand-Expression #`expr) '--)]
        [(+ expr)
         #`(make-PrefixExpression #,(stx->region stx) #,(expand-Expression #`expr) '+)]
        [(- expr)
         #`(make-PrefixExpression #,(stx->region stx) #,(expand-Expression #`expr) '-)]
        [(~ expr)
         #`(make-PrefixExpression #,(stx->region stx) #,(expand-Expression #`expr) '~)]
        [(! expr)
         #`(make-PrefixExpression #,(stx->region stx) #,(expand-Expression #`expr) '!)]))
    (define (expand-InfixExpression stx)
      (syntax-case stx (* / % + -
                          << >> >>> < > <= >=
                          instanceof in
                          == != === !==
                          & ^ \|
                          && \|\|)
        [(* left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '* #,(expand-Expression #`right))]
        [(/ left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '/ #,(expand-Expression #`right))]
        [(% left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '% #,(expand-Expression #`right))]
        [(+ left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '+ #,(expand-Expression #`right))]
        [(- left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '- #,(expand-Expression #`right))]
        [(<< left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '<< #,(expand-Expression #`right))]
        [(>> left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '>> #,(expand-Expression #`right))]
        [(>>> left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '>>> #,(expand-Expression #`right))]
        [(< left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '< #,(expand-Expression #`right))]
        [(> left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '> #,(expand-Expression #`right))]
        [(<= left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '<= #,(expand-Expression #`right))]
        [(>= left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '>= #,(expand-Expression #`right))]
        [(instanceof left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) 'instanceof #,(expand-Expression #`right))]
        [(in left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) 'in #,(expand-Expression #`right))]
        [(== left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '== #,(expand-Expression #`right))]
        [(!= left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '!= #,(expand-Expression #`right))]
        [(=== left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '=== #,(expand-Expression #`right))]
        [(!== left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '!== #,(expand-Expression #`right))]
        [(& left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '& #,(expand-Expression #`right))]
        [(^ left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '^ #,(expand-Expression #`right))]
        [(\| left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '\| #,(expand-Expression #`right))]
        [(&& left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '&& #,(expand-Expression #`right))]
        [(\|\| left right) #`(make-InfixExpression #,(stx->region stx) #,(expand-Expression #`left) '\|\| #,(expand-Expression #`right))]))
    (define (expand-ConditionalExpression stx)
      (syntax-case stx (if)
        [(if test consequent alternative)
         #`(make-ConditionalExpression #,(stx->region stx)
                                       #,(expand-Expression #`test)
                                       #,(expand-Expression #`consequent)
                                       #,(expand-Expression #`alternative))]))
    (define (expand-AssignmentExpression stx)
      (syntax-case stx (= *= /= %= += -= <<= >>= >>>= &= ^= \|=)
        [(lhs = rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '= #,(expand-Expression #`rhs))]
        [(lhs *= rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '*= #,(expand-Expression #`rhs))]
        [(lhs /= rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '/= #,(expand-Expression #`rhs))]
        [(lhs %= rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '%= #,(expand-Expression #`rhs))]
        [(lhs += rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '+= #,(expand-Expression #`rhs))]
        [(lhs -= rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '-= #,(expand-Expression #`rhs))]
        [(lhs <<= rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '<<= #,(expand-Expression #`rhs))]
        [(lhs >>= rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '>>= #,(expand-Expression #`rhs))]
        [(lhs >>>= rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '>>>= #,(expand-Expression #`rhs))]
        [(lhs &= rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '&= #,(expand-Expression #`rhs))]
        [(lhs ^= rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '^= #,(expand-Expression #`rhs))]
        [(lhs \|= rhs) #`(make-AssignmentExpression #,(stx->region stx) #,(expand-Expression #`lhs) '\|= #,(expand-Expression #`rhs))]))
    (define (expand-FunctionExpression stx)
      (syntax-case stx (lambda)
        [(lambda (arg ...) body ...)
         #`(make-FunctionExpression #,(stx->region stx)
                                    #f
                                    (list #,@(map expand-Identifier
                                                  (syntax->list #`(arg ...))))
                                    (list #,@(map expand-SourceElement
                                                  (syntax->list #`(body ...)))))]
        [(lambda name (arg ...) body ...)
         #`(make-FunctionExpression #,(stx->region stx)
                                    #,(expand-Identifier #`name)
                                    (list #,@(map expand-Identifier
                                                  (syntax->list #`(arg ...))))
                                    (list #,@(map expand-SourceElement
                                                  (syntax->list #`(body ...)))))]))
    (define (expand-CallExpression stx)
      (syntax-case stx ()
        [(method arg ...)
         #`(make-CallExpression #,(stx->region stx)
                                #,(expand-Expression #`method)
                                (list #,@(map expand-Expression
                                              (syntax->list #`(arg ...)))))]))
    (define expand-Expression
      ((or-expand "Expression")
       expand-unquote
       expand-StringLiteral expand-NumericLiteral
       expand-BooleanLiteral expand-NullLiteral
       expand-RegexpLiteral expand-ArrayLiteral
       expand-ObjectLiteral
       expand-ThisReference expand-VarReference
       expand-BracketReference expand-DotReference
       expand-NewExpression expand-PostfixExpression
       expand-PrefixExpression expand-InfixExpression
       expand-ConditionalExpression expand-AssignmentExpression
       expand-FunctionExpression
       expand-CallExpression))
    ; Statements
    (define (expand-BlockStatement stx)
      (syntax-case stx (begin)
        [(begin stmts ...)
         #`(make-BlockStatement #,(stx->region stx)
                                (list #,@(map expand-SubStatement
                                              (syntax->list #`(stmts ...)))))]))
    
    (define (expand-ExpressionStatement stx)
      (syntax-case stx (ignore)
        [(ignore expr)
         #`(make-ExpressionStatement #,(stx->region stx)
                                     #,(expand-Expression #`expr))]))
    (define (expand-IfStatement stx)
      (syntax-case stx (if)
        [(if test then)
         #`(make-IfStatement #,(stx->region stx)
                             #,(expand-Expression #`test)
                             #,(expand-SubStatement #`then)
                             #f)]
        [(if test then else)
         #`(make-IfStatement #,(stx->region stx)
                             #,(expand-Expression #`test)
                             #,(expand-SubStatement #`then)
                             #,(expand-SubStatement #`else))]))
    (define (expand-DoWhileStatement stx)
      (syntax-case stx (do while)
        [(do body while test)
         #`(make-DoWhileStatement #,(stx->region stx)
                                  #,(expand-SubStatement #`body)
                                  #,(expand-Expression #`test))]))
    (define (expand-WhileStatement stx)
      (syntax-case stx (while)
        [(while test body)
         #`(make-WhileStatement #,(stx->region stx)
                                #,(expand-Expression #`test)
                                #,(expand-SubStatement #`body))]))
    ; XXX
    (define (expand-ForStatement stx)
      (syntax-case stx (for and)
        [(for init (and test ...) incr body)
         #`(make-ForStatement #,(stx->region stx)
                              #,(expand-Expression #`init)
                              (list #,@(map expand-Expression
                                            (syntax->list #`(test ...))))
                              #,(expand-Expression #`incr)
                              #,(expand-SubStatement #`body))]))
    (define (expand-ForInStatement stx)
      (syntax-case stx (for in)
        [(for (lhs in container) body)
         #`(make-ForInStatement #,(stx->region stx)
                                #,(((or-expand "ForIn")
                                    expand-unquote
                                    expand-Expression
                                    expand-VariableDeclaration)
                                   #`lhs)
                                #,(expand-Expression #`container)
                                #,(expand-SubStatement #`body))]))
    (define (expand-ContinueStatement stx)
      (syntax-case stx (continue)
        [(continue)
         #`(make-ContinueStatement #,(stx->region stx) #f)]
        [(continue id)
         #`(make-ContinueStatement #,(stx->region stx) #,(expand-Identifier #`id))]))
    (define (expand-BreakStatement stx)
      (syntax-case stx (break)
        [(break)
         #`(make-BreakStatement #,(stx->region stx) #f)]
        [(break id)
         #`(make-BreakStatement #,(stx->region stx) #,(expand-Identifier #`id))]))
    (define (expand-ReturnStatement stx)
      (syntax-case stx (return)
        [(return)
         #`(make-ReturnStatement #,(stx->region stx) #f)]
        [(return expr)
         #`(make-ReturnStatement #,(stx->region stx) #,(expand-Expression #`expr))]))
    (define (expand-WithStatement stx)
      (syntax-case stx (with)
        [(with context body)
         #`(make-WithStatement #,(stx->region stx)
                               #,(expand-Expression #`context)
                               #,(expand-SubStatement #`body))]))
    (define (expand-SwitchStatement stx)
      (syntax-case stx (switch)
        [(switch expr case ...)
         #`(make-SwitchStatement #,(stx->region stx)
                                 #,(expand-Expression #`expr)
                                 (list #,@(map expand-CaseClause
                                               (syntax->list #`(case ...)))))]))
    (define (expand-LabelledStatement stx)
      (syntax-case stx (:)
        [(label : stmt)
         #`(make-LabelledStatement #,(stx->region stx)
                                   #,(expand-Identifier #`label)
                                   #,(expand-SubStatement #`stmt))]))
    (define (expand-ThrowStatement stx)
      (syntax-case stx (throw)
        [(throw expr)
         #`(make-ThrowStatement #,(stx->region stx)
                                #,(expand-Expression #`expr))]))
    (define (expand-TryStatement stx)
      (syntax-case stx (try finally)
        [(try body catch ...)
         #`(make-TryStatement #,(stx->region stx)
                              #,(expand-SubStatement #`body)
                              (list #,@(map expand-CatchClause
                                            (syntax->list #`(catch ...))))
                              #f)]
        [(try body catch ... (finally stmt))
         #`(make-TryStatement #,(stx->region stx)
                              #,(expand-SubStatement #`body)
                              (list #,@(map expand-CatchClause
                                            (syntax->list #`(catch ...))))
                              #,(expand-SubStatement #`stmt))]))
    (define expand-Statement
      ((or-expand "Statement")
       expand-unquote
       expand-BlockStatement 
       expand-ExpressionStatement expand-IfStatement
       expand-DoWhileStatement expand-WhileStatement
       expand-ForStatement expand-ForInStatement
       expand-ContinueStatement expand-BreakStatement
       expand-ReturnStatement expand-WithStatement
       expand-SwitchStatement expand-LabelledStatement
       expand-ThrowStatement expand-TryStatement))
    (define expand-SubStatement expand-Statement)
    ; Other
    (define (expand-Identifier stx)
      (match stx
        [(? identifier?)
         #`(make-Identifier #,(stx->region stx)
                            '#,stx)]))
    (define expand-Property
      ((or-expand "Property")
       expand-Identifier
       expand-StringLiteral
       expand-NumericLiteral))
    (define (expand-CaseClause stx)
      (syntax-case stx (case)
        [(case ans ...) 
         #`(make-CaseClause #,(stx->region stx)
                            #f 
                            (list #,@(map expand-SubStatement 
                                          (syntax->list #`(ans ...)))))]
        [(case ques ans ...)
         #`(make-CaseClause #,(stx->region stx)
                            #,(expand-Expression #`ques)
                            (list #,@(map expand-SubStatement 
                                          (syntax->list #`(ans ...)))))]))
    (define (expand-CatchClause stx)
      (syntax-case stx (catch)
        [(catch id body)
         #`(make-CatchClause #,(stx->region stx)
                             #,(expand-Identifier #`id)
                             #,(expand-SubStatement #`body))]))
    ; SourceElements
    (define expand-SourceElement
      ((or-expand "SourceElement")
       expand-Statement
       expand-Declaration))
    ; Main
    (syntax-case stx ()
      [(_ expr)
       (expand-SourceElement #`expr)]))
  
  ; Marshaling
  (define javascript-marshal/property
    (match-lambda
      [(? symbol? datum)
       (make-Identifier #f datum)]
      [(? number? datum)
       (make-NumericLiteral #f datum)]
      [(? string? datum)
       (make-StringLiteral #f datum)]))
  
  (define javascript-marshal
    (match-lambda
      [(hash-table (k v) ...)
       (make-ObjectLiteral #f 
                           (map (lambda (k v)
                                  (cons (javascript-marshal/property k)
                                        (javascript-marshal v)))
                                k v))]
      [(list (list-rest k v) ...)
       (make-ObjectLiteral #f 
                           (map (lambda (k v)
                                  (cons (javascript-marshal/property k)
                                        (javascript-marshal v)))
                                k v))]
      [(list d ...)
       (make-ArrayLiteral #f (map javascript-marshal d))]
      [(vector d ...)
       (make-ArrayLiteral #f (map javascript-marshal d))]
      [(? boolean? datum)
       (make-BooleanLiteral #f datum)]
      [(? void? datum)
       (make-NullLiteral #f)]
      [(? number? datum)
       (make-NumericLiteral #f datum)]
      [(? string? datum)
       (make-StringLiteral #f datum)]))
  
  (define javascript-unmarshal/property
    (match-lambda
      [(struct Identifier (_ d))
       d]
      [(struct NumericLiteral (_ d))
       d]
      [(struct StringLiteral (_ d))
       d]))
  (define javascript-unmarshal
    (match-lambda
      [(struct StringLiteral (_ d))
       d]
      [(struct NumericLiteral (_ d))
       d]
      [(struct NullLiteral (_))
       (void)]
      [(struct BooleanLiteral (_ d))
       d]
      [(struct ArrayLiteral (_ l))
       (map javascript-unmarshal l)]
      [(struct ObjectLiteral (_ (list (list-rest k v) ...)))
       (map (lambda (k v)
              (cons (javascript-unmarshal/property k)
                    (javascript-unmarshal v)))
            k v)]))
  
  ; String API 
  (define javascript->string pretty-format)
  (define string->javascript parse-expression)
  
  (define-syntax js
    (syntax-rules ()
      [(_ expr)
       (javascript->string (javascript expr))]))
  
  (provide js
           javascript
           javascript-marshal
           javascript-unmarshal
           javascript->string
           string->javascript))