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

(in-package :alef)

(define-condition syntax-error ()
  ((expr :initarg :expr :reader expr :type pnode))
  (:report (lambda (condition stream)
             (format stream "Syntax error in")
             (print-pnode (expr condition) stream))))

(defun lgraph-from-pattern (pattern)
  (declare (pnode pattern))
  (let* ((root (make-gnode (pnode-symbol pattern)))
         (formals/children (loop for arg in (pnode-children pattern :actuals)
                                 for (child formals/child) = (multiple-value-list (lgraph-from-pattern arg))
                                 do (gnode-add-child root child)
                                 append formals/child))
         (formals (unless (or (eql (pnode-symbol pattern) :wildcard)
                              (constructor-p (pnode-symbol pattern)))
                    (list (cons (pnode-symbol pattern) root)))))
    (values root (append formals formals/children))))

(defun rgraph-from-expr (expr vars virtuals)
  (declare (pnode expr) (list vars) (list virtuals))
  (labels ((varref-p (pnode)
             (declare (pnode pnode))
             (assoc (pnode-symbol pnode) vars))
           
           (varrefs-in-lambda (lambda-body lambda-formals)
             (declare (pnode lambda-body) (list lambda-formals))
             (append (when (and (varref-p lambda-body)
                                (not (member (pnode-symbol lambda-body) lambda-formals :key #'pnode-symbol)))
                       (list (make-pnode (pnode-symbol lambda-body))))
                     (loop for field in (pnode-fields lambda-body)
                           appending (loop for expr in (pnode-children lambda-body field)
                                           appending (varrefs-in-lambda expr lambda-formals))))))
    (case (pnode-symbol expr)
      ((let)
       (let* ((new-vars (loop for var-decl in (pnode-children expr :decls)
                              for var-name = (pnode-symbol var-decl)
                              collect (cons var-name (make-gnode var-name))))
              (vars (append new-vars vars)))
         (loop for var-decl in (pnode-children expr :decls)
               for (var-name . var-graph) in new-vars
               do (overwrite-gnode var-graph (rgraph-from-expr (pnode-child var-decl :body) vars virtuals)))
         (rgraph-from-expr (pnode-child expr :body) vars virtuals)))
             
      ((apply)
       (let ((root (make-gnode 'apply)))
         (gnode-add-child root (rgraph-from-expr (pnode-child expr :fun) vars virtuals))         
         (dolist (arg (pnode-children expr :actuals) root)
           (gnode-add-child root (rgraph-from-expr arg vars virtuals)))))
      
      ((lambda)
       (let ((lambda-body (pnode-child expr :body))
             (args (pnode-children expr :formals)))
         (let ((lifted-name (gensym "LAMBDA"))
               (args/ctxt (varrefs-in-lambda lambda-body args)))
           (add-function-decl-forward lifted-name)
           (let ((args (append args/ctxt args)))
             (add-function-src lifted-name (mapcar #'pnode-symbol args) lambda-body)              
             (parse-define lifted-name args (list) lambda-body :virtual-map virtuals))
           (let ((lambda/call (make-gnode lifted-name)))
             (dolist (arg/ctxt args/ctxt)
               (gnode-add-child lambda/call (rgraph-from-expr arg/ctxt vars virtuals)))
             lambda/call))))
      
      (otherwise
       (cond
         ((varref-p expr)
          (cdr (assoc (pnode-symbol expr) vars)))
         
         ((constructor-p (pnode-symbol expr))
          (let ((root (make-gnode (pnode-symbol expr))))
            (dolist (arg (pnode-children expr :actuals) root)
              (gnode-add-child root (rgraph-from-expr arg vars virtuals)))))
         
         ((virtual-function-p (pnode-symbol expr))
          (let ((gnode (rgraph-from-virtual (pnode-symbol expr) (pnode-signature expr) virtuals)))
            (add-passed-overrides (pnode-symbol expr) (pnode-signature expr) gnode virtuals)
            gnode))
         
         ((function-p (pnode-symbol expr))
          (let* ((gnode (make-gnode (pnode-symbol expr))))
            (add-passed-overrides (pnode-symbol expr) (pnode-signature expr) gnode virtuals)
            gnode))

         (t
          (error 'syntax-error :expr expr)))))))

(defun rgraph-from-virtual (fun-name fun-signature virtuals)
  (declare (symbol fun-name) (signature fun-signature) (list virtuals))
  (let ((discriminator/template (get-virtual-discriminator fun-name))
        (type/template (signature-type (get-function-decl fun-name))))
    (let ((substs (hindley-milner (list (list (signature-type fun-signature) type/template)))))
      (rgraph-from-override fun-name (subst-typedesc substs discriminator/template) virtuals))))

(defun rgraph-from-override (virtual-name discriminator virtuals)
  (declare (symbol virtual-name) (typedesc discriminator) (list virtuals))
  (if (typevar-p discriminator)
      (let ((virtual-formal (cdr (assoc (list virtual-name discriminator) virtuals :test #'equal))))
        (assert virtual-formal () "Internal error: no virtual argument to resolve call (~A ~A)" virtual-name (type-supertype discriminator))
        virtual-formal)
      (make-gnode (list virtual-name (type-supertype discriminator)))))

;;; TODO: This *may* need some cleanup :)
(defun add-passed-overrides (fun-name signature/call gnode virtuals)
  (declare (symbol fun-name) (signature signature/call) (gnode gnode) (list virtuals))
  (labels ((add-passed-overrides/recursive (signature substs gnode)
             (declare (signature signature) (gnode gnode))              
             (dolist (req (signature-reqs signature))
               (destructuring-bind (fun-name discr) (subst-requirement substs req)
                 (let ((gnode-passed (rgraph-from-override fun-name discr virtuals)))
                   (gnode-add-child gnode gnode-passed)
                   (if (typevar-p discr)
                       (add-passed-overrides/recursive (signature-from-function-decl fun-name) () gnode-passed)
                       (let ((discriminator/virtual (get-virtual-discriminator fun-name))
                             (signature/virtual (get-function-decl fun-name)))
                         (let* ((substs/virtual (hindley-milner (list (list discr discriminator/virtual))))
                                (discriminator (type-supertype (subst-typedesc substs/virtual discriminator/virtual)))
                                (signature/override (or (get-function-decl/override fun-name discriminator)
                                                        (error 'typecheck-error/overload :requirement req)))
                                (substs/override (hindley-milner (subst-equations substs/virtual (list (list (signature-type signature/override) (signature-type signature/virtual)))))))
                           (add-passed-overrides/recursive signature/override substs/override gnode-passed)))))))))
      
    (let* ((signature
            (if (virtual-function-p fun-name)
                (let ((discriminator/template (get-virtual-discriminator fun-name))
                      (signature/template (get-function-decl fun-name)))
                  (let* ((substs (hindley-milner (list (list (signature-type signature/call) (signature-type signature/template)))))
                         (discriminator (subst-typedesc substs discriminator/template)))
                    (if (typevar-p discriminator)                 
                        (subst-signature substs signature/template)
                        (signature-from-function-decl (list fun-name (type-supertype discriminator))))))             
                (signature-from-function-decl fun-name)))
           (substs
            (hindley-milner (list (list (signature-type signature/call) (signature-type signature))))))
      (add-passed-overrides/recursive signature substs gnode))))