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

(in-package :alef)

(defvar *types* (list))
(defvar *types/native* (list))
(defvar *constructors* (list))
(defvar *function-impls/src* (make-hash-table))
(defvar *function-impls* (make-hash-table :test #'equal))
(defvar *virtuals* (make-hash-table :test #'equal))
(defvar *native-functions* (list))
(defvar *declarations* (make-symbol-table))
(defvar *declarations/native* (make-hash-table))

(defmacro with-registry (&body body)
  `(let ((*declarations* (make-symbol-table))
         (*function-impls/src* (make-hash-table))
         (*virtuals* (make-hash-table :test #'equal))
         (*function-impls* (make-hash-table :test #'equal))
         (*types* (list))
         (*constructors* (list)))
     ,@body))

(deftype funspec () 'tree)

(defun constructor-p (symbol)
  (typecase symbol
    (integer (values t 'int))
    (string (values t 'string))
    (t
     (let ((constructor (cdr (assoc symbol *constructors*))))
       (when constructor (values t (constructor-type constructor)))))))

(defun type-p (type)
  (declare (symbol type))
  (or (assoc type *types*)
      (member type *types/native*)))

(defun list-types ()
  (mapcar #'car *types*))

(defun list-functions ()
  (loop for function-name being the hash-key of *function-impls/src*
        collect function-name))

(defun list-virtuals ()
  (loop for virtual-name being the hash-key of *virtuals*
        collect virtual-name))

(defun native-function-p (symbol)
  (assoc symbol *native-functions*))

(defun function-p (symbol)
  (and (not (constructor-p symbol))
       (or (native-function-p symbol)
           (nth-value 1 (symbol-table-get *declarations* symbol)))))

(defun virtual-function-p (symbol)
  (and (function-p symbol)
       (gethash symbol *virtuals*)))

(defun get-virtual-discriminator (fun-name)
  (car (gethash fun-name *virtuals*)))

(defun get-virtual-overrides (fun-name)
  (cdr (gethash fun-name *virtuals*)))

(defun list-overrides (fun-name)
  (declare (symbol fun-name))
  (loop for overload being the hash-key of (get-virtual-overrides fun-name)
        collect overload))

(defun add-function-decl* (fun-name discriminator type reqs)
  (declare (symbol fun-name) (list reqs))
  (assert (not (nth-value 1 (symbol-table-get *declarations* fun-name))) ()
          "Function ~A is already declared" fun-name)
  (symbol-table-add *declarations* fun-name
                    (list discriminator
                          (make-signature (curry-type type) (loop for (fun discr) in reqs collect (list fun (type-supertype discr)))))))

(defun add-function-decl (fun-name type reqs)
  (add-function-decl* fun-name () type reqs))

(defun set-function-decl (fun-name signature)
  (declare (symbol fun-name) (signature signature))
  (assert (nth-value 1 (symbol-table-get *declarations* fun-name)) ()
          "Function ~A is not yet declared" fun-name)
  (assert (null (symbol-table-get *declarations* fun-name)) ()
          "Function ~A is already declared" fun-name)
  (symbol-table-overwrite *declarations* fun-name (list () signature)))

(defun add-function-decl/override (fun-name override signature)
  (declare (symbol fun-name) (typedesc override) (signature signature))
  (assert (virtual-function-p fun-name) () "~A is not a virtual" fun-name)
  (let ((discriminator (type-supertype override)))
    (assert (member discriminator (list-overrides fun-name)) () "(~A ~A) is not known" fun-name discriminator)
    (symbol-table-add *declarations* (list fun-name discriminator) (list () signature))))

(defun get-function-decl (fun-name)
  (declare (funspec fun-name))
  (let ((decl (symbol-table-get *declarations* fun-name)))
    (if decl
        (destructuring-bind (discriminator signature) decl
          (values signature discriminator)))))

(defun get-function-decl/override (fun-name discriminator)
  (declare (symbol fun-name))
  (get-function-decl (list fun-name discriminator)))

(defun add-function-decl/virtual (fun-name discriminator type reqs)
  (add-function-decl* fun-name discriminator type reqs)
  (assert (not (nth-value 1 (gethash fun-name *virtuals*))) ()
          "Virtual function ~A already has overrides" fun-name)
  (setf (gethash fun-name *virtuals*) (cons discriminator (make-hash-table))))

(defun add-function-decl-forward (fun-name)
  (assert (not (nth-value 1 (symbol-table-get *declarations* fun-name))) ()
          "Function ~A is already declared" fun-name)
  (symbol-table-add *declarations* fun-name nil))

(defun add-function-src (fun-name formals body)
  (declare (symbol fun-name) (list formals) (pnode body))
  (assert (nth-value 1 (symbol-table-get *declarations* fun-name)) ()
          "Function ~A not registered before declaration" fun-name)
  (nconcf (gethash fun-name *function-impls/src*) (list (list formals body))))

(defun add-function-src/override (fun-name discriminator formals body)
  (declare (symbol fun-name) (symbol discriminator) (list formals) (pnode body))
  (assert (gethash fun-name *virtuals*) ()
          "Override for undefined virtual ~A in ~:*(~A ~A)" fun-name discriminator)
  (nconcf (gethash discriminator (get-virtual-overrides fun-name)) (list (list formals body))))

(defun get-function-srcs (fun-name)
  (declare (funspec fun-name))
  (assert (not (native-function-p fun-name)))
  (cond ((atom fun-name) (gethash fun-name *function-impls/src*))
        (t               (destructuring-bind (virtual discriminator) fun-name
                           (unless (virtual-function-p virtual)
                             (error "Invalid function specifier ~A" fun-name))
                           (assert (not (typevar-p discriminator)) () "Internal error: override ~A is not yet resolved" fun-name)
                           (get-virtual-srcs virtual discriminator)))))

(defun get-virtual-srcs (fun-name discriminator)
  (declare (symbol discriminator))
  (gethash discriminator (get-virtual-overrides fun-name)))

(defun add-function-impl (fun-spec pattern formal-map virtual-map impl)
  (declare (funspec fun-spec) (gnode pattern impl))
  (unless (consp fun-spec) ; TODO
    (assert (nth-value 1 (gethash fun-spec *function-impls/src*)) ()
            "Function ~A is not added to source pool before registering implementation" fun-spec)) 
  (nconcf (gethash fun-spec *function-impls*) (list (list pattern formal-map virtual-map impl))))

(defun get-function-impls (fun-spec)
  (declare (funspec fun-spec))
  (assert (not (native-function-p fun-spec)))
  (gethash fun-spec *function-impls*))

;;; TODO: reqs from type
(defun add-type (type-name type-params)
  (declare (symbol type-name) (list type-params))
  (assert (not (assoc type-name *types*)) () "Type ~A already defined" type-name)
  (push (cons type-name (make-typeinfo type-name type-params)) *types*))

(defun instantiate-supertype (supertype)
  (declare (symbol supertype))
  (if (member supertype *types/native*)
      supertype
      (let ((typeinfo (cdr (assoc supertype *types*))))
        (unless typeinfo
          (error "Internal error: ~A is not a supertype" supertype))    
        (cons supertype (typeinfo-params typeinfo)))))

(defun add-constructors (supertype constructors)
  (declare (symbol supertype) (list constructors))
  (assert (assoc supertype *types*) () "Type ~A not yet defined" supertype)
  (let ((typeinfo (cdr (assoc supertype *types*))))
    (assert (not (typeinfo-constructors (cdr (assoc supertype *types*)))) () "Constructors of ~A already defined" supertype)
    (let ((type (instantiate-supertype supertype)))
      (dolist (constructor constructors)
        (destructuring-bind (constructor-name &rest constructor-params) constructor
          (when (assoc constructor-name *constructors*)
            (error "Constructor ~A already defined" constructor-name))
          (let ((constructor-info (make-constructor constructor-name supertype (make-signature (curry-type `(fun ,@constructor-params ,type))))))
            (push (cons constructor-name constructor-info)
                  *constructors*)
            (push constructor-info (typeinfo-constructors typeinfo))))))))

(defun constructors (type)
  (typeinfo-constructors (cdr (assoc type *types*))))