;;; -*- Mode:Common-Lisp; Package:SYstem-internals; Base:10; Fonts:(cptfont HL12B HL12BI) -*-

;Ï1; Functions to get information about flavorsÏ*
;Ï1; LaMott Oren 1983Ï*
;Ï1;Ï*

(defun ticl:show-flavor-init (name &optional (previous nil) &aux flavor)
  "Ï2This function returns the init keywords accepted by flavor NAME.Ï*"
  (block ()
    (when (null (setq flavor (flavorp name)))
      (format t "~%~S Is not a flavor or the name of one" name)
      (return (values)))
    (return
     (let* ((children (si:flavor-depends-on flavor))
	    (prev (append previous children)))
       (loop for f in children
             when (or (null previous) (not (member f previous :test #'eq)))
             append (ticl:show-flavor-init f prev) into init-list
             finally (return (append (si:flavor-init-keywords flavor) init-list)))))
    nil)) 


(defun ticl:show-flavor (name &optional (indent 0) (previous nil) &aux flavor)
  "Ï2This function displays the hierarchy of the flavors used by NAME.
NAME is the flavor; It may be the name of a flavor, an instance of a flavor or the actual
flavor structure. INDENT and PREVIOUS are used internally for recursive calls.Ï*"
  (declare)
  (block ()
    (when (null (setq flavor (flavorp name)))
      (format t "~%~S Is not a flavor or the name of one" name)
      (return (values)))
    (terpri)
    (princ (flavor-and-short-documentation-string (si:flavor-name flavor) indent))
    (return
     (let* ((children (si:flavor-depends-on flavor))
	    (prev (append previous children)))
       (dolist (f children)
	 (if (or (null previous) (not (member f previous :test #'eq)))
	   (ticl:show-flavor f (+ indent 2) prev)))))
    ())) 

(defun ticl:show-flavor-users (name &optional (indent 0) (previous nil) &aux flavor)
  "Ï2This function displays the hierarchy of the flavors that use NAME.
NAME is the flavor; It may be the name of a flavor, an instance of a flavor or the actual
flavor structure. INDENT and PREVIOUS are used internally for recursive calls.Ï*"
  (declare)
  (block ()
    (when (null (setq flavor (flavorp name)))
      (format t "~%~S Is not a flavor or the name of one" name)
      (return (values)))
    (terpri)
    (princ (flavor-and-short-documentation-string (si:flavor-name flavor) indent))
    (return
     (let* ((children (si:flavor-depended-on-by flavor))
	    (prev (append previous children)))
       (dolist (f children)
	 (if (or (null previous) (not (member f previous :test #'eq)))
	   (ticl:show-flavor-users f (+ indent 2) prev)))))
    ())) 


(defun ticl:show-flavors-that-use (flavor-or-instance &optional directly-p &aux flavor-name)
  "Ï2List all the flavors that include the specified flavor.
This doesn't find uninstantiated flavors whose decendents (other than children) include
the specified flavor.Ï*"
  (declare)
  (block ()
    (cond
      ((instancep flavor-or-instance)
       (setq flavor-name (type-of flavor-or-instance)))
      ((and (symbolp flavor-or-instance) (get flavor-or-instance 'si:flavor))
       (setq flavor-name flavor-or-instance))
      (t (format () "~%~S is not a flavor or the name of one" flavor-or-instance)
       (return (values))))
    (return
     (dolist (flavor *all-flavor-names*)
       (let* ((f (flavorp flavor))
	      (included-flavor
	       (or
		(and (not directly-p)
		   (member flavor-name (si:flavor-depends-on-all f) :test #'eq))
		(member flavor-name (si:flavor-depends-on f) :test #'eq)
		(member flavor-name (si:flavor-includes f) :test #'eq))))
	 (when included-flavor
	   (terpri)
	   (princ (flavor-and-short-documentation-string flavor))))))
    ())) 


(defun ticl:show-included-flavors (instance &optional (dont-use '(tv:superior)) (indent 2) (previous nil) &aux flavor
  instance-variable name-list)
  "Ï2Recursively print the instance variable name and flavor name of all the instance
variables whose DATA-TYPE is DTP-INSTANCE or whose DATA-TYPE is DTP-LIST and the
list elements are DTP-INSTANCE.  This is an easy way to print the hierarchy of window
panes and blinkers associated with a window. A special hack is included to ignore the
instance variable named TV:SUPERIOR. If this was included the program whould print all
the windows on the lisp machine.Ï*"
  ;Ï1;Ï*
  ;Ï1; Find the flavor or report error.Ï*
  ;Ï1;Ï*
  (declare)
  ;Ï1;Ï*
  ;Ï1; Find all instance variables that are flavors.Ï*
  ;Ï1;Ï*
  (block ()
    (setq flavor
	  (cond
	    ((instancep instance) (flavorp instance))
	    (t (format t "~%~S Is not a flavor" instance) (return (values)))))
    (dolist (symbol (si:flavor-all-instance-variables flavor))
      (setq instance-variable
	    (let ((locative (locate-in-instance instance symbol)))
	      (and (location-boundp locative) (cdr locative))))
      (dolist (variable (if (listp instance-variable)
		   instance-variable
		   (list instance-variable)))
	(cond
	  ((not (instancep  variable)) (return (values)))
	  ((member symbol dont-use :test #'eq) (return (values)))
	  ((member variable previous :test #'eq)
	   (nconc (cdr (assoc variable name-list :test #'eq)) (list symbol)))
	  (t (setq previous (append previous (list variable)))
	   (setq name-list (nconc name-list (list (list variable symbol))))))))
    (dolist (symbol name-list)
      (format t "~%~V@T~A  ~s" indent (cdr symbol)
	      (si:flavor-name (get (type-of (first symbol)) 'si:flavor)))
      (ticl:show-included-flavors (first symbol) dont-use (+ indent 2) previous))
    (return instance)
    ())
  ;Ï1;Ï*
  ;Ï1; Print flavor list & do recursive call.Ï*
  ;Ï1;Ï*
) 


(defun ticl:show-methods (name &optional (full-doc nil) (stream *standard-output*))
  "Ï2List all the methods of a flavor along with arglist & short documentation.Ï*"
  (prog (flavor
	 methods)
    (when (null (setq flavor (flavorp name)))
      (format t "~%~S Is not a flavor or the name of one" name)
      (return (values)))
    (setq methods (flavor-method-function-specs flavor))
    (setq methods
	  (sort methods
		#'(lambda (x y)
		    (alphalessp (string (car (last x))) (string (car (last y)))))))
    (dolist (method methods)
      (terpri stream)
      (princ
       (function-and-short-documentation-string method
						0 full-doc)
       stream)
      (cond
	(full-doc (terpri stream)))))) 

;Ï1-----------------------------------------------------------------------------Ï*

(defun flavor-and-short-documentation-string (flavor-name &optional (indent 0))
  (let* ((doc
	  (second (member :documentation (si:flavor-plist (flavorp flavor-name)) :test #'eq)))
	 (doc-string (or (and (listp doc) (second doc)) doc))
	 (first-doc-string (extract-first-line doc-string)))
    (string-append (format () "~v@t~s~30t" indent flavor-name)
		   (if first-doc-string
		     (format () ":~a" first-doc-string)
		     "")))) 


(defun flavorp (name)
  "Ï2Return the flavor structure of NAME. Returns nil if NAME is not a flavor
or an instance of a flavor.Ï*"
  (typecase name 
    (symbol (get name 'si:flavor))
    (si:flavor name)
    (instance (si:instance-flavor name))))





