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

(in-package :alef)

(defconstant +csharp-ns+ "Alef")

(defun csharp-name (sym)
  (typecase sym
    (cons
     (format nil "(~{~A~^:~})" (mapcar #'csharp-name sym)))
    (symbol
     (case sym
       (+/int "PlusInt")
       (-/int "MinusInt")
       (*/int "MulInt")
       (//int "DivInt")
       (</int "LtInt")
       (=/int "EqInt")
       (show/int "ShowInt")
       (+/string "PlusString")
       (+ "Plus")
       (- "Minus")
       (* "Mul")
       (/ "Div")
       (otherwise (symbol-name sym))))))

(defun csharp-name/class (sym)
  (let ((csharp-name (string-capitalize (csharp-name sym))))
    (if (alpha-char-p (char csharp-name 0))
        csharp-name
        (format nil "c~A" csharp-name))))

(defun csharp-name/enum (sym)
  (string-upcase (csharp-name sym)))

(defun csharp-name/var (sym)
  (string-downcase (csharp-name sym)))

(defun csharp-name/var/actual (sym)
  `(:unescape ,(format nil "actual_~A" (escape-string (csharp-name/var sym)))))

(defun compile-csharp/value (type sym)
  (case type    
    (int `(new "decimal" ,sym))
    (string `(string-lit ,sym))
    (otherwise `(call (dot "ID" ,(csharp-name/class type) ,(csharp-name/class sym))))))

(defun compile-csharp/lgraph (lgraph formal-map virtual-map)
  (declare (gnode lgraph))
  (let ((varnum 0))    
    (labels ((submatcher (pattern expr)
               (loop for subpattern in (gnode-children pattern)
                     for i from 0
                     for subexpr = `(index (dot ,expr "children") ,i)
                     append (matcher subpattern subexpr)))
             
             (matcher (pattern expr)
               (unless (eql (gnode-symbol pattern) :wildcard)
                 (multiple-value-bind (constructorp type) (constructor-p (gnode-symbol pattern))
                   (if constructorp
                       (let ((varname `(:unescape ,(format nil "P~A" (- (incf varnum) 1)))))
                         `((var (,varname :type (dot ,+csharp-ns+ "Runtime" "Node")) ,expr)
                           (call "ReduceExprToCons" ,varname)
                           (cond ((not (call (dot "object" "Equals")
                                             (dot ,varname "objPayload")
                                             ,(compile-csharp/value type (gnode-symbol pattern))))
                                  (return "false")))
                           ,@(submatcher pattern varname)))
                       `((assign ,(csharp-name/var/actual (gnode-symbol pattern)) ,expr)))))))
      `(,@(loop for (formal/sym . formal/gnode) in (append virtual-map formal-map)
                collect `(var (,(csharp-name/var/actual formal/sym) :type (dot ,+csharp-ns+ "Runtime" "Node"))))
        (empty-line)
        ,@(submatcher lgraph "node")))))

(defun compile-csharp/rgraph (rgraph formal-map virtual-map)
  (let ((varnum 0)
        (vars (make-hash-table)))
    (loop for (formal/sym . formal/gnode) in (append virtual-map formal-map)
          do (setf (gethash formal/gnode vars) (csharp-name/var/actual formal/sym)))
    
    (labels ((payload-for-symbol (sym)
               (multiple-value-bind (constructorp type) (constructor-p sym)
                 (cond (constructorp
                        (compile-csharp/value type sym))

                       ((eql sym 'apply)
                        `(new (dot ,+csharp-ns+ "LangID" "Apply")))

                       (t
                        `(new (dot ,+csharp-ns+ "ID" ,(csharp-name/class sym)))))))
             
             (create-result (gnode)
               (let ((image (gethash gnode vars)))
                 (if image
                     image
                     (let ((varname `(:unescape ,(format nil "R~A" (- (incf varnum) 1)))))
                       (setf (gethash gnode vars) varname)
                       (values varname
                               `((var (,varname :type (dot ,+csharp-ns+ "Runtime" "Node"))
                                      (new (dot ,+csharp-ns+ "Runtime" "Node") ,(payload-for-symbol (gnode-symbol gnode))))
                                 ,@(loop for gnode/child in (gnode-children gnode)
                                         append (multiple-value-bind (subexpr subcode) (create-result gnode/child)
                                                  `(,@subcode
                                                    (call (dot ,varname "Add") ,subexpr)))))))))))
      (multiple-value-bind (var code) (create-result rgraph)
        `(,@code
          (call (dot "node" "Overwrite") ,var)
          (return "true"))))))

(defun compile-csharp/type (type)
  (declare (symbol type))
  (let ((classname (csharp-name/class type))
        (constructors (mapcar #'constructor-symbol (constructors type))))
    `(class (,classname :extends (instantiate-generic (dot ,+csharp-ns+ "Runtime" "ConstructorTag")
                                                      (dot ,classname "Kcons")))
            (enum ("Kcons" :visibility :public)
                  ,@(loop for constructor in constructors
                          collect (csharp-name/enum constructor)))
            (empty-line)
            (constructor (:visibility :public
                                      :formals ((var ("kcons" :type "Kcons")))
                                      :delegated-constructor (base "kcons")))
            ,@(loop for constructor in constructors
                    append `((empty-line)
                             (procedure (,(csharp-name/class constructor) :visibility :public :staticp t :type ,classname)
                                        (return (new ,classname (dot "Kcons" ,(csharp-name/enum constructor))))))))))

(defun compile-csharp/function/decl (function-name)
  (let ((classname (csharp-name/class function-name)))
    `(class (,classname :extends (instantiate-generic (dot ,+csharp-ns+ "Runtime" "FunctionTag")
                                                      (dot ,+csharp-ns+ "Prog" ,classname))))))

(defun compile-csharp/function/body (function-name impls)
  `(class (,(csharp-name/class function-name) :extends (dot ,+csharp-ns+ "Runtime" "FunctionBase"))
          ,@(loop for (pattern formal-map virtual-map body) in impls
                  for i from 1
                  collect `(procedure ((:unescape ,(format nil "Reduce_~D" i)) :visibility :private :staticp t :type "bool"
                                        :formals ((var ("node" :type (dot ,+csharp-ns+ "Runtime" "Node")))))
                                      ,@(compile-csharp/lgraph pattern formal-map virtual-map)
                                      (empty-line)
                                      ,@(compile-csharp/rgraph body formal-map virtual-map)))
          (procedure ("Reduce" :visibility :internal :overridep t
                               :formals ((var ("node" :type (dot ,+csharp-ns+ "Runtime" "Node")))))
                     (cond ,@(loop for impl in impls
                                   for i from 1
                                   collect `((call (:unescape ,(format nil "Reduce_~D" i)) "node") (return))))
                     (throw (new "NoMatch")))))

(defun compile-csharp ()
  (let ((funspecs (nconc (list-functions) (mapcan #'(lambda (virtual) (mapcar #'(lambda (override)
                                                                             (list virtual override)) (list-overrides virtual)))
                                                  (list-virtuals)))))
    `((namespace (,+csharp-ns+ "ID")
                 ,@(loop for type in (list-types)
                         collect (compile-csharp/type type))
                 ,@(loop for funspec in funspecs collect (compile-csharp/function/decl funspec)))
     (namespace (,+csharp-ns+ "Prog")
                ,@(loop for funspec in funspecs
                        collect (compile-csharp/function/body funspec (get-function-impls funspec)))))))

(defun write-csharp (file-name)
  (with-open-file (s file-name :direction :output :if-exists :supersede :if-does-not-exist :create)
    (let ((cw (make-instance 'csharp-writer :out-stream s)))
      
      (loop for code in (compile-csharp)
            do (unparse-csharp cw code)))))

(defun compile-program (output-filename program)
  (with-registry
    (load-program program)
    (write-csharp output-filename)))