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

(in-package :alef)

(defun pnode-from-expr (expr)
  (typecase expr
    (atom
     (make-pnode (case expr
                   ((_) :wildcard)
                   (otherwise expr))))
    (cons
     (case (first expr)
       ((let)
        (destructuring-bind ((&rest lets) body) (rest expr)
           (let ((let-node (make-pnode 'let)))
             (pnode-add-children let-node :decls
                                 (loop for (left right) in lets
                                       for decl-node = (make-pnode left)
                                       do (pnode-add-child decl-node :body (pnode-from-expr right))
                                       collect decl-node))
             (pnode-add-child let-node :body (pnode-from-expr body))
             let-node)))
       ((lambda)
        (destructuring-bind ((&rest formals) body) (rest expr)
          (let ((lambda-node (make-pnode 'lambda)))
            (pnode-add-children lambda-node :formals (mapcar #'pnode-from-expr formals))
            (pnode-add-child lambda-node :body (pnode-from-expr body))
            lambda-node)))
       (otherwise
        (if (constructor-p (first expr))
            (let ((root (make-pnode (first expr))))
              (pnode-add-children root :actuals (mapcar #'pnode-from-expr (rest expr)))
              root)
            (let ((root (make-pnode 'apply)))       
              (pnode-add-child root :fun (pnode-from-expr (first expr)))
              (pnode-add-children root :actuals (mapcar #'pnode-from-expr (rest expr)))
              root)))))))

(defun expr-from-pnode (pnode)
  (declare ((or null pnode) pnode))
  (when pnode
    (let ((expr (case (pnode-symbol pnode)
                  ((let)
                   `(let (,@(loop for decl in (pnode-children pnode :decls)
                                  for name = (pnode-symbol decl)
                                  for value = (expr-from-pnode (pnode-child decl :body))
                                  collect `(,name ,value)))
                      ,(expr-from-pnode (pnode-child pnode :body))))    
                  ((lambda)
                   `(lambda (,@(mapcar #'expr-from-pnode (pnode-children pnode :formals)))
                      ,(expr-from-pnode (pnode-child pnode :body))))
                  ((apply)
                   `(,(expr-from-pnode (pnode-child pnode :fun)) ,@(mapcar #'expr-from-pnode (pnode-children pnode :actuals))))
                  (otherwise
                   (if (pnode-children pnode :actuals)
                       `(,(pnode-symbol pnode) ,@(mapcar #'expr-from-pnode (pnode-children pnode :actuals)))
                       (pnode-symbol pnode))))))
      (if (pnode-signature pnode)
          `(:type ,(pnode-signature pnode) ,expr)
          expr))))