path: root/metaenv.lisp

(in-package :agnostic-lizard)

; basic metaenv class interface and NOP default implementations

(defgeneric metaenv-function-like-entries (obj)
            (:documentation
              "Query the list of function-like entries from a metaenv object"))
(defgeneric metaenv-variable-like-entries (obj)
            (:documentation
              "Query the list of variable-like entries from a metaenv object"))
(defgeneric metaenv-blocks (obj)
            (:documentation
              "Query the list of defined blocks from a metaenv object"))
(defgeneric metaenv-tags (obj)
            (:documentation
              "Query the list of defined tags from a metaenv object"))
(defgeneric metaenv-fallback-env (obj)
            (:documentation
              "Query the fallback environment object from a metaenv object"))

(defgeneric metaenv-add-function-like-entry (obj entry)
            (:documentation
              "Add a function-like entry into the metaenv object.
The entry should follow the format described in wrap-function-like-env.
The entry will shadow previously available entries with the same name."))
(defgeneric metaenv-add-variable-like-entry (obj entry)
            (:documentation
              "Add a variable-like entry into the metaenv object.
The entry should follow the format described in wrap-variable-like-env.
The entry will shadow previously available entries with the same name." ))
(defgeneric metaenv-add-block (obj name)
            (:documentation
              "Add a block into the metaenv object."))
(defgeneric metaenv-add-tag (obj name)
            (:documentation
              "Add a tag into the metaenv object."))

(defgeneric metaenv-clone-args (obj)
            (:documentation
              "The needed initargs for copying a metaenv-related object"))
(defgeneric metaenv-clone (obj &optional overrides)
            (:documentation
              "Create a copy of a metaenv-related object"))

(defmethod metaenv-function-like-entries ((obj t)))
(defmethod metaenv-variable-like-entries ((obj t)))
(defmethod metaenv-blocks ((obj t)))
(defmethod metaenv-tags ((obj t)))
(defmethod metaenv-fallback-env ((obj t)))

(defmethod metaenv-add-function-like-entry ((obj t) (entry t)))
(defmethod metaenv-add-variable-like-entry ((obj t) (entry t)))
(defmethod metaenv-add-block ((obj t) (name t)))
(defmethod metaenv-add-tag ((obj t) (name t)))

; The interface is enough to define building a similar environment

(defun metaenv-wrap-form (obj form)
  "Wrap the form into environment-setting wrappers corresponding to all the entries of obj."
  (let*
    ((form form)
     (form
       (wrap-function-like-env
         (metaenv-function-like-entries obj) form))
     (form
       (wrap-variable-like-env
         (metaenv-variable-like-entries obj) form))
     (form (wrap-block-env (metaenv-blocks obj) form))
     (form (wrap-tag-env (metaenv-tags obj) form)))
    form))

(defun with-metaenv-built-env (obj var code)
  "Evaluate code in the lexical environment where var is bound to the lexical environment object described by obj"
  (eval
    (metaenv-wrap-form
      obj
      `(eval-with-current-environment
         (,var) ,@code))))

; The basic metaenv class and methods

(defclass metaenv ()
  ((function-like
     :initarg :function-like :initarg :func :initarg :fun :initarg :fn
     :initform nil :accessor metaenv-function-like-entries)
   (variable-like :initarg :variable-like :initarg :var :initform nil
                  :accessor metaenv-variable-like-entries)
   (blocks :initarg :blocks :initarg :block :initform nil
           :accessor metaenv-blocks)
   (tags :initarg :tags :initarg :tag :initform nil :accessor metaenv-tags)
   (fallback-env
     :initarg :fallback-env :initarg :env :initform nil
     :accessor metaenv-fallback-env
     :documentation "A slot for storing environment obtained via an &environment parameter"))
  (:documentation "The basic object holding the lexical environment data for macroexpansion"))

(defmethod metaenv-add-function-like-entry ((obj metaenv) (entry t))
  (push entry (metaenv-function-like-entries obj)))
(defmethod metaenv-add-variable-like-entry ((obj metaenv) (entry t))
  (push entry (metaenv-variable-like-entries obj)))
(defmethod metaenv-add-block ((obj metaenv) (name t))
  (push name (metaenv-blocks obj)))
(defmethod metaenv-add-tag ((obj metaenv) (name t))
  (pushnew name (metaenv-tags obj)))

(defmethod metaenv-clone-args ((obj metaenv))
  (list
    :function-like (metaenv-function-like-entries obj)
    :variable-like (metaenv-variable-like-entries obj)
    :blocks (metaenv-blocks obj)
    :tags (metaenv-tags obj)
    :fallback-env (metaenv-fallback-env obj)))

(defmethod metaenv-clone ((obj metaenv) &optional overrides)
  (apply
    'make-instance 'metaenv
    (append
      overrides
      (metaenv-clone-args obj))))

; A helper for output
(defmethod print-object ((obj metaenv) stream)
  (format stream "#<~a:~{ ~S~}>"
          (type-of obj)
          (loop
            for arg in (metaenv-clone-args obj)
            collect
            (cond
              ((keywordp arg) arg)
              ((symbolp arg) `',arg)
              ((consp arg) `',arg)
              (t arg)))))

; A useful helper for expansions
(defun metaenv-irrelevant-for-macroexpand (obj)
  "Check if the metaenv obj is the same as the fallback environment for macroexpand-1"
  (and
    (loop
      with fbe := (metaenv-fallback-env obj)
      with seen := (make-hash-table)
      for fn in (metaenv-function-like-entries obj)
      when (second fn)
      unless (or
               (gethash (first fn) seen)
               (and
                 (eq (first (second fn)) :plain)
                 (null (macro-function (first fn) fbe))))
      return nil
      do (setf (gethash (first fn) seen) t)
      finally (return t))
    (loop
      with fbe := (metaenv-fallback-env obj)
      with seen := (make-hash-table)
      for fn in (metaenv-variable-like-entries obj)
      when (second fn)
      unless (or
               (gethash (first fn) seen)
               (and
                 (eq (first (second fn)) :plain)
                 (eq (first fn) (macroexpand-1 (first fn) fbe))))
      return nil
      do (setf (gethash (first fn) seen) t)
      finally (return t))))

(defclass walker-metaenv (metaenv)
  ((on-function-form :initform #'values :initarg :on-function-form
                     :accessor metaenv-on-function-form)
   (on-function-form-pre
     :initform #'values :initarg :on-function-form-pre
     :accessor metaenv-on-function-form-pre)
   (on-every-form :initform #'values :initarg :on-every-form
                  :accessor metaenv-on-every-form)
   (on-every-form-pre :initform #'values :initarg :on-every-form-pre
                  :accessor metaenv-on-every-form-pre)
   (on-special-form-pre :initform #'values :initarg :on-special-form-pre
                     :accessor metaenv-on-special-form-pre)
   (on-special-form :initform #'values :initarg :on-special-form
                     :accessor metaenv-on-special-form)
   (on-macroexpanded-form :initform #'values :initarg :on-macroexpanded-form
                     :accessor metaenv-on-macroexpanded-form))
  (:documentation "An extended walker environment object.
Here we keep a few handlers to allow transformations of the code during walking."))

(defmethod metaenv-clone-args :around ((obj walker-metaenv))
  (append
    (call-next-method)
    (list
      :on-function-form (metaenv-on-function-form obj)
      :on-function-form-pre (metaenv-on-function-form-pre obj)
      :on-special-form (metaenv-on-special-form obj)
      :on-special-form-pre (metaenv-on-special-form-pre obj)
      :on-every-form (metaenv-on-every-form obj)
      :on-every-form-pre (metaenv-on-every-form-pre obj)
      :on-macroexpanded-form (metaenv-on-macroexpanded-form obj))))

(defmethod metaenv-clone ((obj walker-metaenv) &optional overrides)
  (apply
    'make-instance 'walker-metaenv
    (append
      overrides
      (metaenv-clone-args obj))))

(defclass macro-walker-metaenv (walker-metaenv)
  ((create-macro
     :initform t :initarg :create-macro
     :accessor metaenv-create-macro
     :documentation "Whether to do expansion or just create a macro call that will be able to get proper environment")
   (recursive-label
     :initform (gensym) :initarg :recursive-label
     :accessor metaenv-recursive-label
     :documentation
     "A label to distinguish the forms freshly created in relation to the current environment.")
   (on-macro-walker-create-macro
     :initform 'values :initarg :on-macro-walker-create-macro
     :accessor metaenv-on-macro-walker-create-macro
     :documentation
     "A handler invoked when macro-walker creates a new macro"))
  (:documentation "A version of walker-metaenv that can store additional information for expanding to a form with macro calls.
This approach allows to use Common Lisp implementation's own handling of environment.
We still keep track of environment just for portable access to the list of discovered lexical environment entries."))

(defmethod metaenv-clone-args :around ((obj macro-walker-metaenv))
  (append
    (call-next-method)
    (list
      :create-macro (metaenv-create-macro obj)
      :recursive-label (metaenv-recursive-label obj)
      :on-macro-walker-create-macro (metaenv-on-macro-walker-create-macro obj))))

(defmethod metaenv-clone ((obj macro-walker-metaenv) &optional overrides)
  (apply
    'make-instance 'macro-walker-metaenv
    (append
      overrides
      (metaenv-clone-args obj))))

(defmethod metaenv-recursive-label (obj) nil)

(defmacro metaenv-macro-macroexpand-all (form &environment env &optional extra-env)
  "A helper macro for recapturing environment"
  (let*
    ((envcopy (cond
                ((null extra-env) (make-instance 'macro-walker-metaenv))
                ((consp extra-env) (eval extra-env))
                (t (metaenv-clone extra-env)))))
    (setf (metaenv-create-macro envcopy) nil)
    (setf (metaenv-fallback-env envcopy) env)
    (metaenv-macroexpand-all form envcopy)))

(defmacro metaenv-macro-macroexpand-all-wrapper (form env)
  "This wrapper does nothing but protects form from metaenv-macro-walker-turn-to-quoted"
  (declare (ignorable env))
  form)

(defmethod metaenv-macroexpand-all :around (form (env macro-walker-metaenv))
  (if (metaenv-create-macro env)
    (progn
    `(metaenv-macro-macroexpand-all-wrapper
       ,(funcall
          (metaenv-on-macro-walker-create-macro env)
          `(metaenv-macro-macroexpand-all ,form ,env) env)
       ,env))
    (let* ((envcopy (metaenv-clone env)))
      (setf (metaenv-create-macro envcopy) t)
      (call-next-method form envcopy))))

(defmethod metaenv-macroexpand-1 (form (env macro-walker-metaenv))
  (macroexpand-1 form (metaenv-fallback-env env)))

(defun metaenv-macro-walker-turn-to-quoted (form env &optional cdr-branch)
  "Convert a partially walked form into code producing the expansion of the form after the walk is completed"
  (cond
    ((not (consp form)) `(quote ,form))
    ((and
       (not cdr-branch)
       (find (first form)
             '(metaenv-macro-macroexpand-all-wrapper))
       (eq (metaenv-recursive-label (ignore-errors (third form)))
           (metaenv-recursive-label env)))
     form)
    (t `(cons ,(metaenv-macro-walker-turn-to-quoted (car form) env)
              ,(metaenv-macro-walker-turn-to-quoted (cdr form) env t)))))

(defmacro macro-walk-form (form &rest handler-definitions)
  "Walk the form inside the current lexical environment using the handlers from handler-definitions.
See walk-form for details about handlers.
The resulting form after walking is returned as the macroexpansion."
  `(metaenv-macro-macroexpand-all
     ,form
     (make-instance 'macro-walker-metaenv
       ,@ handler-definitions)))

(defmacro macro-macroexpand-all (form &rest handler-definitions &key
                                      (on-every-form ''values)
                                      (on-macro-walker-create-macro ''values))
  "Produce code returning the full macroexpansion of the form in the current lexical environment.
Optionally, run handlers. :on-every-form will be run before quoting and wrapping in environment handling helpers."
  `(macro-walk-form
     ,form
     :on-every-form (lambda (form env)
                      (metaenv-macro-walker-turn-to-quoted
                        (funcall ,on-every-form
                                 form env) env))
     :on-macro-walker-create-macro
     (lambda (form env)
       (metaenv-wrap-form env
         (funcall ,on-macro-walker-create-macro form env)))
     ,@ handler-definitions))