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

(in-package :alef)

(define-condition nomatch ()
  ((fun-spec :type funspec :initarg :fun-spec :reader fun-spec))
  (:report (lambda (condition stream)
             (format stream "Non-exhaustive patterns for ~A" (fun-spec condition)))))

(defun bind-actual (expr pattern)
  (declare (gnode expr pattern))
  (cond
    ((eql (gnode-symbol pattern) :wildcard)
     nil)
    
    ((constructor-p (gnode-symbol pattern)) ; deconstruction
     (reduce-expr* expr)
     (unless (eql (gnode-symbol expr) (gnode-symbol pattern))
       (error 'nomatch))
     (bind-children expr pattern))
    
    (t ; formal parameter decl
     (list (cons pattern expr)))))

(defun bind-children (expr pattern)
  (declare (gnode expr pattern))
  (mapcan #'bind-actual (gnode-children expr) (gnode-children pattern)))

(defun reduce-call (call pattern impl)
  (declare (gnode call pattern impl))
  (overwrite-gnode call (deepclone-gnode impl (bind-children call pattern))))

(defun reducer/alef (fun-spec impls)
  (declare (funspec fun-spec))
  (lambda (expr)
    (loop for (pattern formal-map virtual-map impl) in impls
          do (handler-case (progn
                             (reduce-call expr pattern impl)
                             (return))
               (nomatch () ()))
          finally (error 'nomatch :fun-spec fun-spec))))

(defun reducer/native (fun)
  (lambda (expr)
    (let ((args (gnode-children expr)))
      (overwrite-gnode expr (make-gnode (apply fun args))))))

(defun reducer (fun-spec)
  (declare (funspec fun-spec))
  (cond ((native-function-p fun-spec)
         (reducer/native (cdr (assoc fun-spec *native-functions*))))
        (t
         (reducer/alef fun-spec (get-function-impls fun-spec)))))

(defvar *visualizer-step*)
(defvar *visualizer-root* nil)

(defun reduce-expr (expr)
  (declare (gnode expr))  
  ;; (when *visualizer-root*
  ;;   (with-open-file (s (format nil "trace/alef-trace-~4,'0D.dot" (incf *visualizer-step*)) :direction :output :if-exists :supersede)
  ;;     (dotfile-write-gnode *visualizer-root* expr s)))
  (let ((symbol (gnode-symbol expr)))
    (unless (constructor-p symbol)
      (case symbol
        ((apply)
         (let ((function (deepclone-gnode (car (gnode-children expr)))))
           (loop while (eql (gnode-symbol function) 'apply)
                 do (reduce-expr function))
           (apply #'gnode-add-children function (cdr (gnode-children expr)))
           (overwrite-gnode expr function)
           (reduce-expr expr)))
        (otherwise
         (funcall (reducer symbol) expr))))))

(defun reduce-expr* (expr)
  "Keep on reducing expr until its root is a constructor"
  (declare (gnode expr))
  (loop until (constructor-p (gnode-symbol expr))
        do (reduce-expr expr)
        finally (return expr)))

(defun run (expr)
  (declare (pnode expr))
  (let ((gnode (rgraph-from-expr expr () ())))
    (let ((*visualizer-step* 0)
          (*visualizer-root* gnode))
      (print-gnode gnode t))))