#|
  This file is a part of stoe project.
  Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#

(uiop:define-package :stoe/shader/walker
  (:use :cl :stoe/core/utils)
  (:export #:walk-1
           #:walk-list
           #:walk
           #:defhandler))
(in-package :stoe/shader/walker)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *form-handlers* (make-hash-table)
    "A special variable containing the handlers for our dsl keywords."))

(defvar *default-handler* nil
  "A special variable containing the default handler used for unknown function symbols.")

(defvar *symbol-handler* nil
  "A special variable containing the default handler used for single symbols.")

(defvar *env* nil
  "A special variable used as a container for the macro environment.")

(defun form-handler (first)
  "Retreive the handler for the symbol FIRST."
  (gethash (intern (symbol-name first) :keyword)
           *form-handlers* *default-handler*))

(defun binding-to-symbol (binding)
  (let ((name (safe-first binding)))
    (cond ((listp name)
           (assert (eq 'setf (first name)))
           (check-type (second name) symbol)
           (second name))
          (t
           name))))

(defmacro with-imposed-bindings (&body body)
  #-sbcl
  `(locally ,@body)
  #+sbcl
  (destructuring-bind ((binder bindings &rest binder-body))
      body
    `(locally
         (declare (sb-ext:disable-package-locks
                   ,@(mapcar 'binding-to-symbol bindings)))
       (,binder ,bindings ,@binder-body))))

(defun function-name-p (name)
  "Return whether NAME is the name of a function."
  (or (symbolp name)
      (and (listp name) (eq (first name) 'setf) (symbolp (second name))
           (not (cddr name)))))

(defun compiler-macroexpand-1 (form &optional env)
  "Try and expand the compiler macro defined for the first element of FORM if it exists."
  (let ((cm (and (listp form) (function-name-p (first form))
                 (compiler-macro-function (first form) env))))
    (if cm
        (funcall *macroexpand-hook* cm form env)
        form)))

(defun walk-1 (form)
  "Walk across the specified form."
  (flet ((handle (form)
           (apply (form-handler (first form)) form)))
    (cond ((and (listp form) (gethash (intern (symbol-name (first form)) :keyword)
                                      *form-handlers*))
           (handle form))
          (t
           (multiple-value-bind (form expanded)
               (macroexpand-1 form *env*)
             (cond (expanded
                    (walk-1 form))
                   (t
                    (typecase form
                      (null nil)
                      (list
                       (let ((next (compiler-macroexpand-1 form)))
                         (if (eq form next)
                             (handle form)
                             (walk-1 next))))
                      (symbol (apply *symbol-handler* form))
                      (t
                       form)))))))))

(defun walk-list (list)
  "Apply `walk-1' to all members of LIST."
  (mapcar #'walk-1 list))

(defun default-form-handler (first &rest rest)
  "Handle FORM when FIRST is not a special form."
  (if (symbolp first)
      `',first
      (walk-1 first)) (walk-list rest))

(defmacro defhandler (symbol lambda-list &body body)
  (let ((syms (safe-list symbol)))
    (let ((func (intern (format nil "~a~a" 'handler- (first syms)))))
      `(progn
         (defun ,func ,lambda-list
           ,@body)
         (setf ,@(loop for sym in syms
                       collect `(gethash ,(intern (symbol-name sym) :keyword)
                                         ,(intern (symbol-name '*form-handlers*)))
                       collect `',func))))))

(defun walk (form handlers default-handler symbol-handler env)
  "Walk the sexp FORM and transform it according to the rules defined in HANDLERS.
When no known symbol is parsed, it is either handled by DEFAULT-HANDLER or by SYMBOL-HANDLER,
whether it is the first symbol of a form or just a single symbol."
  (let ((*form-handlers* handlers)
        (*default-handler* default-handler)
        (*symbol-handler* symbol-handler)
        (*env* env))
    (walk-1 form)))