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

(in-package :alef)

(defun parse-define (fun-spec formals reqs body &key virtual-map)
  (declare ((or symbol list) fun-spec) (list formals) (list reqs) (pnode body))
  (let* ((pattern-graph (make-gnode fun-spec))
         (virtual-map (append virtual-map (loop for req in reqs collect (cons req (make-gnode req))))))
    (loop for (req . virtual-node) in virtual-map
          do (gnode-add-child pattern-graph virtual-node))

    (let* ((formal-map (loop for formal in formals
                             for (formal-graph formal-map*) = (multiple-value-list (lgraph-from-pattern formal))
                             do (gnode-add-child pattern-graph formal-graph)
                             append formal-map*))
           (impl-graph (rgraph-from-expr body formal-map virtual-map)))
      (add-function-impl fun-spec pattern-graph formal-map virtual-map impl-graph))))

(defun parse-deftype/constructors (type-name type-params constructors)
  (declare (symbol type-name) (list type-params) (list constructors) (ignorable type-params))
  (add-constructors type-name (mapcar (lambda (constructor) (if (atom constructor) (list constructor) constructor)) constructors)))

(defmacro walk-program (program &body clauses)
  (with-gensyms (progline op args)
    `(dolist (,progline ,program)
       (destructuring-bind (,op &rest ,args) ,progline
         (case ,op
           ,@(loop for ((keyword . lambda-list) . body) in clauses
                   collect `((,keyword) (destructuring-bind ,lambda-list ,args ,@body))))))))

(defun collect-deftypes (program)
  (walk-program program
    ((deftype type-name params &rest constructors)
     (declare (ignore constructors))
     (add-type type-name params))))

(defun collect-deftypes/constructor (program)
  (walk-program program
    ((deftype type-name params &rest constructors)
     (declare (symbol type-name) (list params) (list constructors) (ignore params))
     (add-constructors type-name (mapcar (lambda (constructor) (if (atom constructor) (list constructor) constructor)) constructors)))))

(defun collect-declares (program)
  (walk-program program
    ((declare fun-name requirements type)
     (add-function-decl fun-name (if (consp type) (cons 'fun type) type) requirements))

    ((declare/virtual (fun-name discriminator) requirements type)
     (add-function-decl/virtual fun-name discriminator (cons 'fun type) requirements))))

(defun collect-defines (program)
  (walk-program program
    ((define fun-name patterns body)
     (declare (ignore patterns body))
     ;; Add forward declarations for undeclared functions only
     (unless (function-p fun-name)
       (add-function-decl-forward fun-name)))))

(defun parse-defines (program)
  (walk-program program
    ((define fun-name patterns body)
     (add-function-src fun-name (mapcar #'pnode-from-expr patterns) (pnode-from-expr body)))

    ((define/override (fun-name discriminator) patterns body)
     (add-function-src/override fun-name discriminator (mapcar #'pnode-from-expr patterns) (pnode-from-expr body)))))

(defun load-program (program)
  (collect-deftypes program)
  (collect-deftypes/constructor program)
    
  (collect-declares program)
  (collect-defines program)
  (parse-defines program)

  ;; Typecheck function definitions and store resolved types as declarations
  (dolist (fun-name (list-functions))
    (let ((signature (typecheck-function fun-name)))
      (with-nice-types
        (format t "~&~A::~A~%" fun-name (show-signature signature)))))
  
  (dolist (virtual (list-virtuals))
    (multiple-value-bind (signature/virtual discriminator/virtual) (get-function-decl virtual)
      (format t "~&~A::~A~%" (list virtual discriminator/virtual) (show-signature signature/virtual))
      (dolist (supertype/override (list-overrides virtual))
        (let ((discriminator/override (instantiate-typevars (instantiate-supertype supertype/override))))
          (let ((signature/override (signature-from-function-srcs (list virtual supertype/override)
                                                                  (get-virtual-srcs virtual supertype/override))))
            (handler-case
                (progn
                  (hindley-milner (list (list (signature-type signature/virtual) (signature-type signature/override))
                                        (list discriminator/virtual discriminator/override)))
                  (add-function-decl/override virtual discriminator/override signature/override)
                  (with-nice-types
                    (format t "~&(~A ~A)::~A~%" virtual supertype/override (show-signature signature/override))))
              (typecheck-error () (error "Bad override of ~A ~A" virtual supertype/override))))))))
  
  ;; Parse function definitions into graphs
  (dolist (fun-name (list-functions))
    (let ((signature (signature-from-function-decl fun-name)))
      (loop for (formals body) in (get-function-srcs fun-name)
            do (parse-define fun-name formals (signature-reqs signature) body))))
  
  (dolist (virtual (list-virtuals))
    (dolist (discriminator (list-overrides virtual))
      (let ((signature (get-function-decl/override virtual discriminator)))
        (let ((srcs (get-virtual-srcs virtual discriminator)))
          (loop for (formals body) in srcs
                do (parse-define (list virtual discriminator) formals (signature-reqs signature) body)))))))

(defun parse-and-run (program)
  (with-registry
    (load-program program)
    (when (not (gethash 'start *function-impls* nil))
      (error "Function ~A not defined" 'start))
    
;;;     (mapcar #'(lambda (x) (print-pnode (second x))) (get-function-srcs 'start))
    (let ((pnode (make-pnode 'start)))
      (setf (pnode-signature pnode) (signature-from-function-decl 'start))
      (print-pnode pnode)
      (run pnode))))