;;; Alef Lazily Evaluates Functions
;;; (C) 2008-2009 Dr. Gergo ERDI <http://gergo.erdi.hu/>

(in-package :alef)

(defgeneric unparse-csharp/impl (csharp-writer directive &rest args))
(defun unparse-csharp (csharp-writer expr)
  (apply #'unparse-csharp/impl csharp-writer expr))

(defun unparse-descend (csharp-writer expr)
  (typecase expr
    (string (write-code csharp-writer expr :escape t))
    (number (write-code csharp-writer (format nil "~D" expr)))
    (cons   (unparse-csharp csharp-writer expr))))

(defmethod unparse-csharp/impl ((cw csharp-writer) directive &rest args)
  (loop for arg in (cons directive args)
        do (write-code cw arg)))

(defmacro define-unparser ((directive &rest lambda-list) cw-name &body body)
  (let ((args-name (gensym "ARGS")))
    `(defmethod unparse-csharp/impl ((,cw-name csharp-writer) (,(gensym "DIRECTIVE") (eql ',directive)) &rest ,args-name)
       (destructuring-bind ,lambda-list ,args-name
         ,@body))))

(define-unparser (:unescape str) cw
    (write-code cw str))

(define-unparser (namespace path &body body) cw
  (write-code cw "namespace ")
  (loop for name-part in (if (listp path) path (cons path nil))
        for firstp = t then nil
        unless firstp do (write-code cw ".")
        do (unparse-descend cw name-part))
  (write-block cw
    (dolist (decl body)
      (unparse-descend cw decl))))

(defun unparse-visibility (cw visibility)
  (when visibility
    (write-code cw (ecase visibility
                     (:public "public")
                     (:private "private")
                     (:protected "protected")
                     (:internal "internal")))
    (write-code cw " ")))

(define-unparser (class (name &key visibility extends) &body body) cw
  (unparse-visibility cw visibility)
  (write-code cw "class ")
  (unparse-descend cw name)
  (when extends
    (write-code cw ": ")
    (unparse-descend cw extends))
  
  (write-block cw
    (let ((class-path (class-path cw)))
      (setf (class-path cw) (cons name class-path))
      (dolist (decl body)
        (unparse-descend cw decl))
      (setf (class-path cw) class-path))))

(define-unparser (enum (name &key visibility) &body enum-members) cw
  (unparse-visibility cw visibility)
  (write-code cw "enum ")
  (unparse-descend cw name)
  (write-block cw
    (loop for enum-member in enum-members
          for firstp = t then nil
          unless firstp do (write-code cw "," :newline t)
          do (unparse-descend cw enum-member))))

(define-unparser (constructor (&key visibility formals delegated-constructor) &body body) cw
  (assert (car (class-path cw)))
  (unparse-visibility cw visibility)
  (unparse-descend cw (car (class-path cw)))
  (unparse-args cw formals)

  (when delegated-constructor
    (write-code cw ": ")
    (unparse-descend cw delegated-constructor))
  (write-block cw
    (dolist (stmt body)
      (unparse-descend cw stmt))))

(defun unparse-args (cw args &key (before " (") (after ")") (separator ", "))
  (write-code cw before)
  (loop for arg in args
        for firstp = t then nil
        when (not firstp) do (write-code cw separator)
        do (unparse-descend cw arg))
  (write-code cw after))

(defun unparse-stmts (cw stmts) 
  (write-block cw
    (dolist (stmt stmts)
      (unparse-descend cw stmt)
      (write-code cw ";" :newline t))))

(define-unparser (base &rest args) cw
  (write-code cw "base")
  (unparse-args cw args))

(define-unparser (var (name &key type) &optional expr) cw
  (unparse-descend cw (or type "var"))
  (write-code cw " ")
  (unparse-descend cw name)
  (when expr
    (write-code cw " = ")
    (unparse-descend cw expr)))

(define-unparser (procedure (name &key visibility staticp overridep (type "void") formals) &body body) cw
  (unparse-visibility cw visibility)
  (when staticp
    (write-code cw "static "))
  (when overridep
    (write-code cw "override "))
  (unparse-descend cw type)
  (write-code cw " ")
  (unparse-descend cw name)
  (unparse-args cw formals)
  (unparse-stmts cw body))

(define-unparser (block &body body) cw
  (write-block cw
    (dolist (stmt body)
      (unparse-descend cw stmt)
      (write-code cw ";" :newline t))))

(define-unparser (return &optional expr) cw
  (write-code cw "return")
  (when expr
    (write-code cw " ")
    (unparse-descend cw expr)))

(define-unparser (dot arg1 arg2 &rest args) cw
  (loop for arg in (cons arg1 (cons arg2 args))
        for firstp = t then nil
        unless firstp do (write-code cw ".")
        do (unparse-descend cw arg)))

(define-unparser (index obj &rest indices) cw
  (unparse-descend cw obj)
  (unparse-args cw indices :before "[" :after "]"))

(define-unparser (call fun &rest args) cw
  (unparse-descend cw fun)
  (unparse-args cw args))

(define-unparser (new type &rest args) cw
  (write-code cw "new ")
  (unparse-descend cw type)  
  (unparse-args cw args))

(define-unparser (instantiate-generic type &rest typeargs) cw
  (unparse-descend cw type)
  (unparse-args cw typeargs :before "<" :after ">"))

(define-unparser (cond &rest branches) cw
  (loop for (condition . stmts) in branches
        for firstp = t then nil
        do (progn
             (if (not (eql condition :else))
                 (progn
                   (unless firstp (write-code cw "else "))
                   (write-code cw "if (")
                   (unparse-descend cw condition)
                   (write-code cw ")"))
                 (write-code cw "else"))
             (unparse-stmts cw stmts))))

(define-unparser (throw expr) cw
  (write-code cw "throw ")
  (unparse-descend cw expr))

(define-unparser (not expr) cw
  (write-code cw "!(")
  (unparse-descend cw expr)
  (write-code cw ")"))

(define-unparser (is expr type) cw
  (unparse-descend cw expr)
  (write-code cw " is ")
  (unparse-descend cw type))

(define-unparser (empty-line) cw
  (write-newline cw))

(define-unparser (assign lhs rhs) cw
  (unparse-descend cw lhs)
  (write-code cw " = ")
  (unparse-descend cw rhs))

(define-unparser (try (&rest catchers) &body stmts) cw
  (write-code cw "try")
  (unparse-stmts cw stmts)
  (loop for (exception . catcher) in catchers
        do (progn
             (write-code cw "catch (")
             (unparse-descend cw exception)
             (write-code cw ")")
             (unparse-stmts cw catcher))))

(define-unparser (string-lit &rest strings) cw
  (write-code cw (format nil "~{~S~}" strings)))