;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.walker)

(declaim (ftype (function () t) make-empty-lexical-environment))

(defparameter *lexical-environment-functions*
  '((make-empty-lexical-environment  "Returns an empty lexical environment useful for testing and playing around in the repl.")
    (iterate-variables-in-lexenv     "(funcall VISITOR name &key ignored? special? macro? macro-body) for each variable or symbol macro definition in LEXENV.")
    (iterate-functions-in-lexenv     "(funcall VISITOR name &key macro? macro-function) for each function or macro definition in LEXENV.")
    (iterate-blocks-in-lexenv        "(funcall VISITOR name) for each block in LEXENV.")
    (iterate-tags-in-lexenv          "(funcall VISITOR name) for each tag in LEXENV.")
    (augment-lexenv-with-variable)
    (augment-lexenv-with-function)
    (augment-lexenv-with-macro)
    (augment-lexenv-with-symbol-macro)
    (augment-lexenv-with-block)
    (augment-lexenv-with-tag)
    ;; err, they are not lexical...
    (proclaimed-special-variable?/global)
    (declared-variable-type/global)
    ))

;;; set up some docstrings
(loop
   :for (name documentation) :in *lexical-environment-functions*
   :do (when documentation
         (setf (documentation name 'function) documentation)))

(defun missing-lexical-environment-function ()
  (cerror "ignore and try to continue" "This is not implemented for your lisp, sorry. You may try to continue, but...")
  nil)

;;; if there was no definition provided for some of the functions in
;;; *lexical-environment-functions* then register a function that will
;;; signal an error.
(eval-when (:load-toplevel :execute)
  (loop
     :for (name) :in *lexical-environment-functions*
     :do (unless (fboundp name)
           (setf (fdefinition name)
                 (lambda (&rest args)
                   (declare (ignore args))
                   (missing-lexical-environment-function))))))

(defmacro %compile-quoted (form)
  `(compile nil '(lambda () ,form)))

;; TODO rename to RUN-IN-LEXICAL-ENVIRONMENT ?
(defmacro with-captured-lexical-environment ((env-variable form &key (compiler '%compile-quoted)) &body forms)
  "Executes FORMS with lexical environment captured at the point marked with the symbol -HERE-."
  ;; Use private interned symbols to ensure that the body can be printed readably:
  (let ((body '.with-captured-lexical-environment/body.)
        (injector-macro '.with-captured-lexical-environment/injector-macro.))
    `(let ((,body (lambda (,env-variable)
                    ;; TODO: wrap the body in our own handlers that will prevent the errors/failed-asserts reaching COMPILE
                    ,@forms)))
       (declare (special ,body))        ; For the macrolet
       (handler-bind
           (#+sbcl(sb-ext:compiler-note #'muffle-warning)
            (warning #'muffle-warning))
         (,compiler
          ,(subst `(macrolet ((,injector-macro (&environment env)
                                (declare (special ,body))
                                (funcall ,body env)
                                (values)))
                     (,injector-macro))
                  '-here- form)))
       (values))))

(defun augment-lexenv (kind name lexenv &rest args)
  (ecase kind
    (:variable     (progn
                     (assert (null args))
                     (augment-lexenv-with-variable name lexenv)))
    (:function     (progn
                     (assert (null args))
                     (augment-lexenv-with-function name lexenv)))
    (:macro        (destructuring-bind (macro-definition) args
                     (augment-lexenv-with-macro name macro-definition lexenv)))
    (:symbol-macro (destructuring-bind (macro-definition) args
                     (augment-lexenv-with-symbol-macro name macro-definition lexenv)))
    (:block        (progn
                     (assert (null args))
                     (augment-lexenv-with-block name lexenv)))
    (:tag          (progn
                     (assert (null args))
                     (augment-lexenv-with-tag name lexenv)))))

(defmacro augment-lexenv! (kind name env &rest other-datum)
  `(setf ,env (augment-lexenv ,kind ,name ,env ,@other-datum)))

;;;
;;; variables
;;;
(def (macro e) do-variables-in-lexenv ((lexenv name &key
                                               (ignored? (gensym) ignored-provided?)
                                               (special? (gensym) special-provided?)
                                               (macro? (gensym) macro-provided?)
                                               (macro-body (gensym))
                                               (type (gensym) type-provided?))
                                        &body body)
  `(block nil
     (iterate-variables-in-lexenv
      (lambda (,name &key ((:ignored? ,ignored?) nil) ((:special? ,special?) nil)
          ((:macro? ,macro?) nil) ((:macro-body ,macro-body) nil) ((:type ,type) nil))
        (declare (ignorable ,@(unless ignored-provided? (list ignored?))
                            ,@(unless special-provided? (list special?))
                            ,@(unless macro-provided? (list macro? macro-body))
                            ,@(unless type-provided? (list type))))
        ,@body)
      ,lexenv
      :include-macros? ,macro-provided?
      :include-ignored? ,ignored-provided?
      :include-specials? ,special-provided?)))

(def (function e) collect-variables-in-lexenv (lexenv &key include-ignored? (include-specials? t) filter)
  (let ((result (list)))
    (iterate-variables-in-lexenv
     (lambda (name &key ignored? special? &allow-other-keys)
       (when (or (not filter)
                 (funcall filter name :ignored? ignored? :special? special?))
         (push name result)))
     lexenv
     :include-ignored? include-ignored?
     :include-specials? include-specials?)
    (nreverse result)))

(def (function e) find-variable-in-lexenv (name-to-find lexenv &key include-ignored? (include-specials? t))
  (iterate-variables-in-lexenv
   (lambda (name &key ignored? &allow-other-keys)
     (when (eq name name-to-find)
       (return-from find-variable-in-lexenv (values name ignored?))))
   lexenv
   :include-ignored? include-ignored?
   :include-specials? include-specials?)
  (values nil))

;;;
;;; functions
;;;
(def (macro e) do-functions-in-lexenv ((lexenv name &optional
                                               (macro? (gensym) macro-provided?)
                                               (macro-function (gensym) macro-function-provided?))
                                       &body body)
  `(block nil
     (iterate-functions-in-lexenv
      (lambda (,name &key ((:macro? ,macro?)) ((:macro-function ,macro-function)))
        (declare (ignorable ,@(unless macro-provided? (list macro?))
                            ,@(unless macro-function-provided? (list macro-function))))
        ,@body)
      ,lexenv
      :include-macros? ,macro-provided?)))

(def (function e) collect-functions-in-lexenv (lexenv &key filter)
  (let ((result (list)))
    (iterate-functions-in-lexenv
     (lambda (name &key &allow-other-keys)
       (when (or (not filter)
                 (funcall filter name))
         (push name result)))
     lexenv)
    (nreverse result)))

(def (function e) find-function-in-lexenv (name-to-find lexenv)
  (iterate-functions-in-lexenv
   (lambda (name &key &allow-other-keys)
     (when (eq name name-to-find)
       (return-from find-function-in-lexenv (values name))))
   lexenv)
  (values nil))

;;;
;;; macros
;;;
(def (macro e) do-macros-in-lexenv ((lexenv name &optional (macro-fn (gensym) macro-fn-provided?))
                                     &body body &aux (macro? (gensym)))
  `(block nil
     (iterate-functions-in-lexenv
      (lambda (,name &key ((:macro? ,macro?)) ((:macro-function ,macro-fn)))
        ,@(unless macro-fn-provided?
                  `((declare (ignore ,macro-fn))))
        (when ,macro?
          ,@body))
      ,lexenv
      :include-macros? t)))

(def (function e) collect-macros-in-lexenv (lexenv &key filter)
  (let ((result (list)))
    (iterate-functions-in-lexenv
     (lambda (name &key macro? macro-function)
       (declare (ignore macro-function))
       (when (and macro?
                  (or (not filter)
                      (funcall filter name)))
         (push name result)))
     lexenv
     :include-macros? t)
    (nreverse result)))

(def (function e) find-macro-in-lexenv (name-to-find lexenv)
  (iterate-functions-in-lexenv
   (lambda (name &key macro? macro-function)
     (when (and macro? (eq name name-to-find))
       (return-from find-macro-in-lexenv (values name macro-function))))
   lexenv
   :include-macros? t)
  (values nil))

;;;
;;; symbol-macros
;;;
(def (macro e) do-symbol-macros-in-lexenv ((lexenv name &optional (definition (gensym) definition-provided?))
                                            &body body)
  (with-unique-names (macro?)
    `(block nil
       (iterate-variables-in-lexenv
        (lambda (,name &key ((:macro-body ,definition)) ((:macro? ,macro?)) &allow-other-keys)
          ,@(unless definition-provided?
                    `((declare (ignore ,definition))))
          (when ,macro?
            ,@body))
        ,lexenv
        :include-macros? t))))

(def (function e) collect-symbol-macros-in-lexenv (lexenv &key filter)
  (let ((result (list)))
    (iterate-variables-in-lexenv
     (lambda (name &key macro-body macro? &allow-other-keys)
       (declare (ignore macro-body))
       (when (and macro?
                  (or (not filter)
                      (funcall filter name)))
         (push name result)))
     lexenv
     :include-macros? t)
    (nreverse result)))

(def (function e) find-symbol-macro-in-lexenv (name-to-find lexenv)
  (iterate-variables-in-lexenv
   (lambda (name &key macro-body macro? &allow-other-keys)
     (when (and macro? (eq name name-to-find))
       (return-from find-symbol-macro-in-lexenv (values name macro-body))))
   lexenv
   :include-macros? t)
  (values nil))

;;;
;;; blocks
;;;
(def (macro e) do-blocks-in-lexenv ((lexenv name) &body body)
  `(block nil
     (iterate-blocks-in-lexenv
      (lambda (,name)
        ,@body)
      ,lexenv)))

(def (function e) collect-blocks-in-lexenv (lexenv &key filter)
  (let ((result (list)))
    (iterate-blocks-in-lexenv
     (lambda (name)
       (when (or (not filter)
                 (funcall filter name))
         (push name result)))
     lexenv)
    (nreverse result)))

(def (function e) find-block-in-lexenv (name-to-find lexenv)
  (iterate-blocks-in-lexenv
   (lambda (name)
     (when (eq name name-to-find)
       (return-from find-block-in-lexenv (values name))))
   lexenv)
  (values nil))

;;;
;;; tags
;;;
(def (macro e) do-tags-in-lexenv ((lexenv name) &body body)
  `(block nil
     (iterate-tags-in-lexenv
      (lambda (,name)
        ,@body)
      ,lexenv)))

(def (function e) collect-tags-in-lexenv (lexenv &key filter)
  (let ((result (list)))
    (iterate-tags-in-lexenv
     (lambda (name)
       (when (or (not filter)
                 (funcall filter name))
         (push name result)))
     lexenv)
    (nreverse result)))

(def (function e) find-tag-in-lexenv (name-to-find lexenv)
  (iterate-tags-in-lexenv
   (lambda (name)
     (when (eq name name-to-find)
       (return-from find-tag-in-lexenv (values name))))
   lexenv)
  (values nil))