;; visitor.stk -- visitors

(require "path")
(require "edge")

;; A visitor is defined by defining a class that descends from class
;; <visitor>.  It's instantiated by instantiating an object of the
;; visitor class.
(define-class <visitor> ()
  ((path-dir :accessor path-dir :init-keyword :path)))

;; The path-dir slot should probably be a class slot for
;; non-parameterizable visitors...

;; The metavariable for referring to the current visitor (e.g. in a
;; visitor method-- think "self").
(define default-vis-arg 'vis)

;; The metavariable for referring to the current host (e.g. in a
;; visitor method).
(define default-host-arg 'host)

;; Shorthand for defining a visitor with a default path and init code.
(define-macro (define-visitor name . args)
  (let ((supers (get-keyword :extends args '<visitor>))
	(params (get-keyword :params args '()))
	(locals (get-keyword :locals args '()))
	(methods (get-keyword :methods args '()))
	(init-path (get-keyword :path args '()))
	(init-body (get-keyword :init args '()))
	(polymorphic-methods? (get-keyword :polymorphic-methods? args #f)))
    (unless (list? supers) (set! supers (list supers)))
    (set! params (map give-default-init-keyword
		      (map give-default-accessor params)))
    (set! locals (map give-default-accessor locals))
    (unless (null? init-body) (set! init-body (list init-body)))
    (unless (null? init-path)
      (set! init-path `((unless (slot-bound? ,default-vis-arg 'path-dir)
			  (set! [path-dir ,default-vis-arg] ,init-path)))))
    (let* ((param-abbrevs (map compute-slot-abbrev params))
	   (slots (append params locals))
	   (slot-abbrevs (map compute-slot-abbrev slots)))
      (set! methods
	    (map (lambda (m)
		   (expand-visitor-method name slot-abbrevs m
					  polymorphic-methods?))
		 methods))
      (unless (or (not polymorphic-methods?) (null? param-abbrevs))
	(set! init-body (append methods init-body))
	(set! methods '()))
      (unless (or (null? param-abbrevs) (null? init-body))
	(set! init-body `((let ,param-abbrevs ,@init-body))))
      (unless (and (null? init-path) (null? init-body))
	(set! methods
	      (cons
	       `(define-method initialize ((,default-vis-arg ,name) initargs)
		  ,@init-path
		  (next-method)
		  ,@init-body)
	       methods)))
      (unless (null? methods)
	(set! methods
	      `((let ((%set! set!))
		  (define-macro (set! var val)
		    (if (memq var ',(map slot-name slots))
			`(let ((val ,val))
			   (slot-set! ,default-vis-arg ',var val)
			   (%set! ,var val))
			`(%set! ,var ,val)))
		  ,@methods))))
      `(begin
	 (define-class ,name ,supers ,(append params locals))
	 ,@methods
	 ,name))))

;; Give a slot a default accessor with the same name as the slot.
(define-method give-default-accessor ((slot-desc <pair>))
  (append slot-desc (list :accessor (car slot-desc))))
(define-method give-default-accessor (slot-name)
  (list slot-name :accessor slot-name))

;; Give a slot a default init-keyword with the same name as the slot.
(define-method give-default-init-keyword ((slot-desc <pair>))
  (append slot-desc (list :init-keyword (make-keyword (car slot-desc)))))
(define-method give-default-init-keyword (slot-name)
  (list slot-name :init-keyword (make-keyword slot-name)))

;; Convert "(,name ,class . ,body)" shorthand into
;; a method definition.
(define-method expand-visitor-method ((vis-class <symbol>)
				      (slot-abbrevs <list>) (meth <pair>)
				      (polymorphic-methods? <boolean>))
  (let ((name (car meth))
	(class (cadr meth))
	(body (cddr meth))
	(arg default-host-arg))
    (when (list? class)
      ;; method is of the form (before (foo <foo>) ...)
      (set! arg (car class))
      (set! class (cadr class)))
    ;; Define abbreviations for slots on the visitor.
    (unless (or (null? slot-abbrevs) (null? body))
      (set! body `((let ,slot-abbrevs ,@body))))
    ;; We can't just use define-method because it evaluates the
    ;; specializers in the global environment, and defines the generic
    ;; in the current environment.
    (let* ((glob-env (global-environment))
	   (previous (and (symbol-bound? name glob-env) name)))
      (unless (and previous (is-a? (eval previous glob-env) <generic>))
;;;	(eval `(define-generic ,name :default ,previous) glob-env))
	(eval `(define-generic ,name) glob-env))
      `(add-method ,name ,(visitor-method vis-class class arg body)))))

(define-method visitor-method ((vis-class <symbol>)
			       host-class (host-arg <symbol>)
			       (body <list>))
  `(make <method>
	 :specializers (list ,vis-class ,host-class)
	 :procedure    (lambda (next-method ,default-vis-arg ,host-arg)
			 ,@body)))

;; Convert a slot descriptor into a binding (suitable for a `let'
;; expression) for the slot, using the slot name and slot-ref.
(define-method compute-slot-abbrev ((slot-desc <pair>))
  (compute-slot-abbrev (car slot-desc)))
(define-method compute-slot-abbrev ((slot-name <symbol>))
    `(,slot-name (safe-slot-ref ,default-vis-arg ',slot-name)))

;; The slot value if the slot is bound, otherwise #[undefined].
(define-method safe-slot-ref ((obj <object>) (slot-name <symbol>))
 (if (slot-bound? obj slot-name) (slot-ref obj slot-name)))

;; These methods are called for each object in the object graph and for
;; each visitor in the list of participating visitors.
(define-method before ((v <visitor>) obj) @undefined)
(define-method after ((v <visitor>) obj) @undefined)

;; These methods are called for each edge in the object graph and for
;; each visitor in the list of participating visitors.
(define-method before ((v <visitor>) source (e <edge>) target) @undefined)
(define-method after ((v <visitor>) source (e <edge>) target) @undefined)

;; A before method (on an object or an edge) may add visitors to the
;; current traversal by calling add-visitors on the list of visitors
;; to add.  The before methods on any added visitors are immediately
;; called, which may themselves add new visitors.  After the current
;; object or edge has been traversed, the after methods on all
;; visitors are called in reverse order, including the ones that were
;; added in the before methods.
(define-method add-visitors ((visitors <list>))
  (make <added-visitors> :added-visitors visitors))
(define-method add-visitors visitors
  (add-visitors visitors))
(define-method add-visitor (visitor)
  (add-visitors visitor))
(define-method add-visitor visitors
  (add-visitors visitors))
(define-class <added-visitors> ()
  ((added-visitors :accessor added-visitors
		   :init-keyword :added-visitors
		   :initform '())))
(define-method added-visitors (x) '())

;; Call the before method on each visitor in the list of visitors.
;; Return the list of visitors, which may have been added to by the
;; before methods.
(define-method before ((visitors <list>) . args)
  (do-befores visitors args '()))

(define-method do-befores ((visitors <null>) (args <list>)
			   (already-visited <list>))
  already-visited)

(define-method do-befores ((visitors <pair>) (args <list>)
			   (already-visited <list>))
  (let* ((visitor (car visitors))
	 (added (added-visitors (apply before visitor args))))
    (set! added (map (lambda (v) (set-path! v [path-dir visitor])) added))
    (do-befores (append added (cdr visitors))
		args
		(append already-visited (list visitor)))))

;; Call the after method on each visitor in the list of visitors, in
;; reverse order.
(define-method after ((visitors <list>) . args)
  (for-each (lambda (v) (apply after v args)) (reverse visitors)))

;; Set the path of a visitor if it's not already bound,
;; and then return the visitor.
(define-method set-path! ((v <visitor>) (path <path>))
  (unless (slot-bound? v 'path-dir)
    (set! [path-dir v] path))
  v)

;; If we get a class instead of an instance, make one.
(define-method set-path! ((c <class>) (path <path>))
  (set-path! (make c) path))

(provide "visitor")