<commit_before>(in-package :clim-listener)

;;; (C) Copyright 2003 by <NAME> (<EMAIL>)
;;; (C) Copyright 2004 by <NAME> (<EMAIL>)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.


;;; Command table and menu definitions

(define-command-table application-commands)

(define-command-table lisp-dev-commands :inherit-from nil) ;; "Abstract" command table used for defining some translators in
(define-command-table lisp-commands :inherit-from (lisp-dev-commands))

(define-command-table show-commands :inherit-from (lisp-dev-commands))

(define-command-table filesystem-commands
    :inherit-from (directory-stack-commands)
    :menu (("Directory Stack" :menu directory-stack-commands)))

(define-command-table directory-stack-commands)


;;; Presentation types

(define-presentation-type class () :inherit-from 'expression)
(define-presentation-type class-name () :inherit-from 'symbol)
(define-presentation-type slot-definition () :inherit-from 'expression)
(define-presentation-type function-name () :inherit-from 'symbol)
(define-presentation-type process () :inherit-from 'expression)
(define-presentation-type generic-function () :inherit-from 't)

(define-presentation-method presentation-typep
    (object (type generic-function))
  (typep object 'generic-function))

(define-presentation-type standard-generic-function ()
  :inherit-from 'generic-function)

(define-presentation-type method ()
  :inherit-from 'expression)

(define-presentation-type standard-method ()
  :inherit-from 'method)

(define-presentation-type directory-stack () :inherit-from 'expression)
(define-presentation-type bytes () :inherit-from 'integer)
(define-presentation-type lisp-memory-usage () :inherit-from 'bytes)

(define-presentation-type package () :inherit-from 'expression)
(define-presentation-method presentation-typep (object (type package))
  (typep object 'package))

(define-presentation-type package-name () :inherit-from 'string)
(define-presentation-method presentation-typep (object (type package-name))
  (find-package 'object))
    


;;; Presentation methods

(define-presentation-method present (object (type standard-method)
				     stream (view textual-view)
				     &key &allow-other-keys)
  (let ((name (clim-mop:generic-function-name
	       (clim-mop:method-generic-function object)))
	(qualifiers (clim-mop:method-qualifiers object))
	(specializers (clim-mop:method-specializers object))
	(lambda-list (clim-mop:method-lambda-list object))
	(class-of-t (find-class t)))
    (format stream "~S ~{~S ~}(" name qualifiers)
    (multiple-value-bind (required optional rest key key-present)
	(climi::parse-lambda-list lambda-list)
      (loop
	 for spec in specializers
	 for arg in required
	 for first-time = t then nil
	 do
	   (unless first-time
	     (write-char #\space stream))
	   (if (eq spec class-of-t)
	       (present arg 'symbol :stream stream)
	       (progn
		 (write-char #\( stream)
		 (present arg 'symbol :stream stream)
		 (write-char #\space  stream)
		 (with-output-as-presentation (stream spec 'class)
		   (format stream "~S" (clim-mop:class-name spec)))
                 (write-char #\) stream))))
      (when optional
	(format stream " &optional ~{~A ~^ ~}" optional))
      (when rest
	(format stream " &rest ~A" (car rest)))
      (when key-present
	(format stream " &key"))
      (loop
	   for arg in key
	   for key-arg = (cond ((symbolp arg)
				(intern (symbol-name arg) :keyword))
			       ((symbolp (car arg))
				(intern (symbol-name (car arg)) :keyword) )
			       (t (caar arg)))
	   do (format stream " ~S" key-arg))
      (write-char #\) stream))))
  

(define-presentation-method present (object (type generic-function)
                                     stream (view textual-view)
                                     &key &allow-other-keys)
  (princ (clim-mop:generic-function-name object) stream))

(define-presentation-method accept
    ((type generic-function) stream (view textual-view) &key)
  ;; generic-functions are a subclass of standard-object, so they can be
  ;; accepted as expressions!
  (let ((fn (accept 'expression
		    :stream stream
		    :view view
		    :history 'generic-function
		    :prompt nil)))
    ;;
    (when (typep fn 'generic-function)
      (return-from accept fn))
    (handler-case
	(fdefinition fn)
      (error ()
	(simple-parse-error "~S is not the name of a generic function."
			    fn)))))

(define-presentation-method present (object (type bytes)
                                     stream (view textual-view)
                                     &key &allow-other-keys)
  (if (zerop object)
      (princ "0" stream)
    (let* ((suffixes '(" bytes" " KB" " MB" " GB" " TB" " PB"))
           (x (floor (realpart (log object 1000))))
           (idx (min x (1- (length suffixes)))))
      (if (zerop idx)
          (format stream "~A bytes" object)
        (format stream "~,1F~A" (/ object (expt 1000 idx)) (nth idx suffixes))))))

;;; Presentation translators

(define-presentation-translator class-name-to-class
  (class-name class lisp-dev-commands
     :documentation ((object stream) (format stream "Class object ~A" object))
     :gesture T)
  (object)
  (find-class object))

(define-presentation-translator symbol-to-class
  (symbol class lisp-dev-commands
     :documentation ((object stream) (format stream "Class object ~A" object))
     :gesture T
     :tester ((object) (not (not (find-class object nil))))
     :tester-definitive T)
  (object)
  (find-class object))

(define-presentation-translator symbol-to-class-name
  (symbol class-name lisp-dev-commands
     :documentation ((object stream) (format stream "Class ~A" object))
     :gesture T
     :tester ((object) (not (not (find-class object nil))))
     :tester-definitive T)
  (object)
  object)

(define-presentation-translator class-to-class-name
  (class class-name lisp-dev-commands
     :documentation ((object stream) (format stream "Class of ~A" object))
     :gesture T)
  (object)
  (clim-mop:class-name object))

(define-presentation-translator symbol-to-function-name
  (symbol function-name lisp-dev-commands
     :documentation ((object stream) (format stream "Function ~A" object))
     :gesture T
     :tester ((object) (fboundp object))
     :tester-definitive T)
  (object) object)

;;; Application commands

(define-command (com-clear-output :name "Clear Output History"
				  :command-table application-commands
                                  :menu t
				  :provide-output-destination-keyword nil)
    ()
  (window-clear *standard-output*))

;; You have to seperate command arguments with commas..
;; Need to find a better way to input these.

;; McCLIM fixme: Shouldn't we be able to activate before the (args) prompt
;; since defaults are defined?
;; FIXME: Disabled input, as it usually seems to hang.
(define-command (com-run :name "Run" :command-table application-commands :menu t
			 :provide-output-destination-keyword t)
  ((program 'string :prompt "command")
   (args '(sequence string) :default nil :prompt "args"))
  (run-program program args :wait T :input nil))

;; I could replace this command with a keyword to COM-RUN..
(define-command (com-background-run :name "Background Run"
                                    :menu t
				    :command-table application-commands
				    :provide-output-destination-keyword t)
  ((program 'string :prompt "command")
   (args '(sequence string) :default nil :prompt "args"))
  (run-program program args :wait nil :output nil :input nil))

(define-command (com-reload-mime-database :name "Reload Mime Database"
                                          :menu t
                                          :command-table application-commands)
    ()
  (progn
    (load-mime-types)
    (load-mailcaps)))


(add-menu-item-to-command-table (find-command-table 'application-commands) nil :divider nil)

(define-command (com-exit :name "Quit"
			  :command-table application-commands
                          :menu t
			  :provide-output-destination-keyword nil)
    ()
  (frame-exit *application-frame*))



;;; Commands related to Lisp development
;;; ------------------------------------

(defvar *apropos-list* nil
  "The apropos command stores its output here.")

(defparameter *apropos-symbol-unbound-family* :fix)
(defparameter *apropos-symbol-unbound-face*   :roman)
(defparameter *apropos-symbol-bound-family*   :fix)
(defparameter *apropos-symbol-bound-face*     :roman)

;; FIXME: Make this a present method specialzed on a view?

(defun apropos-present-symbol (symbol &optional (stream *standard-output*) show-package)
  (multiple-value-bind (style ink)
      (values
       (if (or (fboundp symbol)
               (boundp  symbol)
               (find-class symbol nil))
           (make-text-style *apropos-symbol-bound-family*
                            *apropos-symbol-unbound-face*
                            :normal)
           (make-text-style *apropos-symbol-unbound-family*
                            *apropos-symbol-bound-face*
                            :normal))
       (cond ((eql (symbol-package symbol)
                   (find-package "KEYWORD"))
              (make-rgb-color 0.46 0.0 0.0))
             ((fboundp symbol)        (make-rgb-color 0.0  0.0  0.3))
             ((find-class symbol nil) (make-rgb-color 0.03 0.35 0.48))
             ((boundp symbol)         (make-rgb-color 0.0  0.0  0.0))
             (t                       (make-rgb-color 0.6  0.6  0.6))))
    (with-drawing-options (stream :ink ink :text-style style)
      (with-output-as-presentation (stream symbol 'clim:symbol)
        (if show-package
            (let ((*package* (find-package :common-lisp-user)))
              (format stream "~W" symbol))
            (princ (symbol-name symbol) stream)))
      (when (boundp symbol)
        (format stream " = ")
        (with-drawing-options (stream :ink +olivedrab+ ;; XXX
                                      :text-style (make-text-style :fix :roman :small))
          (let ((object (symbol-value symbol)))
            (present object (presentation-type-of object) :stream stream)))))))

;; These are used by com-apropos to filter the list of symbols according to the domain keyword
(defgeneric apropos-applicable-p (spec symbol))

(defmethod apropos-applicable-p ((spec (eql 'symbols)) symbol) t)

(defmethod apropos-applicable-p ((spec (eql 'classes)) symbol)
  (find-class symbol nil))  

(defmethod apropos-applicable-p ((spec (eql 'functions)) symbol)
  (fboundp symbol))

(defmethod apropos-applicable-p ((spec (eql 'variables)) symbol)
  (boundp symbol))

(defmethod apropos-applicable-p ((spec (eql 'command-tables)) symbol)
  (find-command-table symbol :errorp nil))

;(defmethod apropos-applicable-p ((spec (eql 'presentation-type)) symbol)
;  (find-presentation-type-class symbol nil))

(define-command (com-apropos :name "Apropos"
			     :command-table lisp-commands
                             :menu t
			     :provide-output-destination-keyword t)
    ((string 'clim:string :prompt "string")
     &key
     (package '(or package-name package) :prompt "in package" :default nil)
     (domain '(member symbols classes functions variables command-tables) :prompt "domain" :default 'symbols))
  (let ((real-package (when package
                        (if (typep package 'package)
                            package
                            (find-package package)))))
    (when (and package (not real-package))
      (cerror "Search all packages instead" "No package specified by ~A could be found." package))
    (let ((symbols (remove-if-not (lambda (sym) (apropos-applicable-p domain sym))
                                  (apropos-list string real-package))))
      (dolist (sym symbols)
        (apropos-present-symbol sym *standard-output* T)
        (terpri))
      (setf *apropos-list* symbols)
      (note "Results have been saved to ~W~%" '*APROPOS-LIST*))))

(define-command (com-trace :name "Trace"
			   :command-table lisp-commands
                           :menu t
			   :provide-output-destination-keyword nil)
    ((fsym 'function-name :prompt "function-name"))
  (if (fboundp fsym)
      (progn 
	(eval `(trace ,fsym))
	(format T "~&Tracing ~W.~%" fsym))
    (format T "~&Function ~W is not defined.~%" fsym)))

(define-command (com-untrace :name "Untrace"
			     :command-table lisp-commands
                             :menu t
			     :provide-output-destination-keyword nil)
    ((fsym 'symbol :prompt "function name"))
  (if (fboundp fsym)
      (progn
	(eval `(untrace ,fsym))
	(format T "~&~W will no longer be traced.~%" fsym))
    (format T "~&Function ~W is not defined.~%" fsym)))


(define-command (com-load-file :name "Load File"
                               :command-table lisp-commands
                               :menu t
			       :provide-output-destination-keyword t)
  ((pathname 'pathname :prompt "pathname"))
  (load pathname))

(define-command (com-compile-file :name "Compile File"
                                  :command-table lisp-commands
                                  :menu t
				  :provide-output-destination-keyword t)
  ((pathname 'pathname :prompt "pathname"))
  (compile-file pathname))

(define-command (com-compile-and-load :name "Compile and load"
                                      :command-table lisp-commands
                                      :menu t
				      :provide-output-destination-keyword t)
  ((pathname 'pathname :prompt "pathname"))
  (load (compile-file pathname)))

(define-command (com-room :name "Room"
                          :command-table lisp-commands
                          :menu t
			  :provide-output-destination-keyword t)
  ()
  (room))

(define-presentation-to-command-translator mem-room-translator
  (lisp-memory-usage com-room lisp-commands
                     :gesture :select
                     :documentation "Room"
                     :pointer-documentation "Room")
  ())
  

(define-presentation-to-command-translator com-show-class-subclasses-translator
  (class-name com-show-class-subclasses lisp-commands
              :menu t
              :documentation "Show Class Subclasses"
              :pointer-documentation "Show Class Subclasses")
  (presentation)
  (list (presentation-object presentation)))


(define-presentation-to-command-translator com-show-class-superclasses-translator
  (class-name com-show-class-superclasses lisp-commands
              :menu t
              :tester ((presentation)
                       (not (eq t (presentation-object presentation))))
              :documentation "Show Class Superclasses"
              :pointer-documentation "Show Class Superclasses")
  (presentation)
  (list (presentation-object presentation)))


(define-presentation-to-command-translator com-show-class-generic-functions-translator
  (class-name com-show-class-generic-functions lisp-commands
              :menu t
              :documentation "Show Class Generic Functions"
              :pointer-documentation "Show Class Generic Functions")
  (presentation)
  (list (presentation-object presentation)))


(define-presentation-to-command-translator com-show-class-slots-translator
  (class-name com-show-class-slots lisp-commands
              :menu t
              :documentation "Show Class Slots"
              :pointer-documentation "Show Class Slots")
  (presentation)
  (list (presentation-object presentation)))


;;; CLOS introspection commands

(defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72))
(defparameter *graph-text-style* (make-text-style :fix :roman :normal))

(defun class-grapher (stream class inferior-fun &key (orientation :horizontal))
  "Does the graphing for Show Class Superclasses and Subclasses commands"
  (let ((normal-ink +foreground-ink+)
        (arrow-ink  *graph-edge-ink*)
	(text-style *graph-text-style*))
    (with-drawing-options (stream :text-style text-style)
      (format-graph-from-roots (list class)
                               #'(lambda (class stream)
                                   (with-drawing-options (stream :ink normal-ink
                                                                 :text-style text-style)
                                     ;; Present class name rather than class here because the printing of the
                                     ;; class object itself is rather long and freaks out the pointer doc pane.
                                     (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name)
                                        ; (surrounding-output-with-border (stream :shape :drop-shadow)
				       (princ (clim-mop:class-name class) stream)))) ;)
                               inferior-fun
                               :stream stream
                               :merge-duplicates T
                               :graph-type :tree
                               :orientation orientation
                               :arc-drawer
                               #'(lambda (stream foo bar x1 y1 x2 y2)
                                   (declare (ignore foo bar))
                                   (draw-arrow* stream x1 y1 x2 y2 :ink arrow-ink))))))

(defun frob-to-class (spec)
  (if (typep spec 'class)
      spec
    (find-class spec nil)))

(define-command (com-show-class-superclasses :name "Show Class Superclasses"
                                             :command-table show-commands
                                             :menu "Class Superclasses"
					     :provide-output-destination-keyword t)
    ((class-spec 'class-name :prompt "class")
     &key
     (orientation 'keyword :prompt "orientation" :default :horizontal))
  (let ((class (frob-to-class class-spec)))
    (if (null class)
	(note "~A is not a defined class." class-spec)
        (class-grapher *standard-output* class #'clim-mop:class-direct-superclasses
                       :orientation orientation))))

(define-command (com-show-class-subclasses :name "Show Class Subclasses"
                                           :command-table show-commands
                                           :menu "Class Subclasses"
					   :provide-output-destination-keyword t)<commit_msg>Made class-grapher update space requirements.<commit_after>(in-package :clim-listener)

;;; (C) Copyright 2003 by <NAME> (<EMAIL>)
;;; (C) Copyright 2004 by <NAME> (<EMAIL>)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.


;;; Command table and menu definitions

(define-command-table application-commands)

(define-command-table lisp-dev-commands :inherit-from nil) ;; "Abstract" command table used for defining some translators in
(define-command-table lisp-commands :inherit-from (lisp-dev-commands))

(define-command-table show-commands :inherit-from (lisp-dev-commands))

(define-command-table filesystem-commands
    :inherit-from (directory-stack-commands)
    :menu (("Directory Stack" :menu directory-stack-commands)))

(define-command-table directory-stack-commands)


;;; Presentation types

(define-presentation-type class () :inherit-from 'expression)
(define-presentation-type class-name () :inherit-from 'symbol)
(define-presentation-type slot-definition () :inherit-from 'expression)
(define-presentation-type function-name () :inherit-from 'symbol)
(define-presentation-type process () :inherit-from 'expression)
(define-presentation-type generic-function () :inherit-from 't)

(define-presentation-method presentation-typep
    (object (type generic-function))
  (typep object 'generic-function))

(define-presentation-type standard-generic-function ()
  :inherit-from 'generic-function)

(define-presentation-type method ()
  :inherit-from 'expression)

(define-presentation-type standard-method ()
  :inherit-from 'method)

(define-presentation-type directory-stack () :inherit-from 'expression)
(define-presentation-type bytes () :inherit-from 'integer)
(define-presentation-type lisp-memory-usage () :inherit-from 'bytes)

(define-presentation-type package () :inherit-from 'expression)
(define-presentation-method presentation-typep (object (type package))
  (typep object 'package))

(define-presentation-type package-name () :inherit-from 'string)
(define-presentation-method presentation-typep (object (type package-name))
  (find-package 'object))
    


;;; Presentation methods

(define-presentation-method present (object (type standard-method)
				     stream (view textual-view)
				     &key &allow-other-keys)
  (let ((name (clim-mop:generic-function-name
	       (clim-mop:method-generic-function object)))
	(qualifiers (clim-mop:method-qualifiers object))
	(specializers (clim-mop:method-specializers object))
	(lambda-list (clim-mop:method-lambda-list object))
	(class-of-t (find-class t)))
    (format stream "~S ~{~S ~}(" name qualifiers)
    (multiple-value-bind (required optional rest key key-present)
	(climi::parse-lambda-list lambda-list)
      (loop
	 for spec in specializers
	 for arg in required
	 for first-time = t then nil
	 do
	   (unless first-time
	     (write-char #\space stream))
	   (if (eq spec class-of-t)
	       (present arg 'symbol :stream stream)
	       (progn
		 (write-char #\( stream)
		 (present arg 'symbol :stream stream)
		 (write-char #\space  stream)
		 (with-output-as-presentation (stream spec 'class)
		   (format stream "~S" (clim-mop:class-name spec)))
                 (write-char #\) stream))))
      (when optional
	(format stream " &optional ~{~A ~^ ~}" optional))
      (when rest
	(format stream " &rest ~A" (car rest)))
      (when key-present
	(format stream " &key"))
      (loop
	   for arg in key
	   for key-arg = (cond ((symbolp arg)
				(intern (symbol-name arg) :keyword))
			       ((symbolp (car arg))
				(intern (symbol-name (car arg)) :keyword) )
			       (t (caar arg)))
	   do (format stream " ~S" key-arg))
      (write-char #\) stream))))
  

(define-presentation-method present (object (type generic-function)
                                     stream (view textual-view)
                                     &key &allow-other-keys)
  (princ (clim-mop:generic-function-name object) stream))

(define-presentation-method accept
    ((type generic-function) stream (view textual-view) &key)
  ;; generic-functions are a subclass of standard-object, so they can be
  ;; accepted as expressions!
  (let ((fn (accept 'expression
		    :stream stream
		    :view view
		    :history 'generic-function
		    :prompt nil)))
    ;;
    (when (typep fn 'generic-function)
      (return-from accept fn))
    (handler-case
	(fdefinition fn)
      (error ()
	(simple-parse-error "~S is not the name of a generic function."
			    fn)))))

(define-presentation-method present (object (type bytes)
                                     stream (view textual-view)
                                     &key &allow-other-keys)
  (if (zerop object)
      (princ "0" stream)
    (let* ((suffixes '(" bytes" " KB" " MB" " GB" " TB" " PB"))
           (x (floor (realpart (log object 1000))))
           (idx (min x (1- (length suffixes)))))
      (if (zerop idx)
          (format stream "~A bytes" object)
        (format stream "~,1F~A" (/ object (expt 1000 idx)) (nth idx suffixes))))))

;;; Presentation translators

(define-presentation-translator class-name-to-class
  (class-name class lisp-dev-commands
     :documentation ((object stream) (format stream "Class object ~A" object))
     :gesture T)
  (object)
  (find-class object))

(define-presentation-translator symbol-to-class
  (symbol class lisp-dev-commands
     :documentation ((object stream) (format stream "Class object ~A" object))
     :gesture T
     :tester ((object) (not (not (find-class object nil))))
     :tester-definitive T)
  (object)
  (find-class object))

(define-presentation-translator symbol-to-class-name
  (symbol class-name lisp-dev-commands
     :documentation ((object stream) (format stream "Class ~A" object))
     :gesture T
     :tester ((object) (not (not (find-class object nil))))
     :tester-definitive T)
  (object)
  object)

(define-presentation-translator class-to-class-name
  (class class-name lisp-dev-commands
     :documentation ((object stream) (format stream "Class of ~A" object))
     :gesture T)
  (object)
  (clim-mop:class-name object))

(define-presentation-translator symbol-to-function-name
  (symbol function-name lisp-dev-commands
     :documentation ((object stream) (format stream "Function ~A" object))
     :gesture T
     :tester ((object) (fboundp object))
     :tester-definitive T)
  (object) object)

;;; Application commands

(define-command (com-clear-output :name "Clear Output History"
				  :command-table application-commands
                                  :menu t
				  :provide-output-destination-keyword nil)
    ()
  (window-clear *standard-output*))

;; You have to seperate command arguments with commas..
;; Need to find a better way to input these.

;; McCLIM fixme: Shouldn't we be able to activate before the (args) prompt
;; since defaults are defined?
;; FIXME: Disabled input, as it usually seems to hang.
(define-command (com-run :name "Run" :command-table application-commands :menu t
			 :provide-output-destination-keyword t)
  ((program 'string :prompt "command")
   (args '(sequence string) :default nil :prompt "args"))
  (run-program program args :wait T :input nil))

;; I could replace this command with a keyword to COM-RUN..
(define-command (com-background-run :name "Background Run"
                                    :menu t
				    :command-table application-commands
				    :provide-output-destination-keyword t)
  ((program 'string :prompt "command")
   (args '(sequence string) :default nil :prompt "args"))
  (run-program program args :wait nil :output nil :input nil))

(define-command (com-reload-mime-database :name "Reload Mime Database"
                                          :menu t
                                          :command-table application-commands)
    ()
  (progn
    (load-mime-types)
    (load-mailcaps)))


(add-menu-item-to-command-table (find-command-table 'application-commands) nil :divider nil)

(define-command (com-exit :name "Quit"
			  :command-table application-commands
                          :menu t
			  :provide-output-destination-keyword nil)
    ()
  (frame-exit *application-frame*))



;;; Commands related to Lisp development
;;; ------------------------------------

(defvar *apropos-list* nil
  "The apropos command stores its output here.")

(defparameter *apropos-symbol-unbound-family* :fix)
(defparameter *apropos-symbol-unbound-face*   :roman)
(defparameter *apropos-symbol-bound-family*   :fix)
(defparameter *apropos-symbol-bound-face*     :roman)

;; FIXME: Make this a present method specialzed on a view?

(defun apropos-present-symbol (symbol &optional (stream *standard-output*) show-package)
  (multiple-value-bind (style ink)
      (values
       (if (or (fboundp symbol)
               (boundp  symbol)
               (find-class symbol nil))
           (make-text-style *apropos-symbol-bound-family*
                            *apropos-symbol-unbound-face*
                            :normal)
           (make-text-style *apropos-symbol-unbound-family*
                            *apropos-symbol-bound-face*
                            :normal))
       (cond ((eql (symbol-package symbol)
                   (find-package "KEYWORD"))
              (make-rgb-color 0.46 0.0 0.0))
             ((fboundp symbol)        (make-rgb-color 0.0  0.0  0.3))
             ((find-class symbol nil) (make-rgb-color 0.03 0.35 0.48))
             ((boundp symbol)         (make-rgb-color 0.0  0.0  0.0))
             (t                       (make-rgb-color 0.6  0.6  0.6))))
    (with-drawing-options (stream :ink ink :text-style style)
      (with-output-as-presentation (stream symbol 'clim:symbol)
        (if show-package
            (let ((*package* (find-package :common-lisp-user)))
              (format stream "~W" symbol))
            (princ (symbol-name symbol) stream)))
      (when (boundp symbol)
        (format stream " = ")
        (with-drawing-options (stream :ink +olivedrab+ ;; XXX
                                      :text-style (make-text-style :fix :roman :small))
          (let ((object (symbol-value symbol)))
            (present object (presentation-type-of object) :stream stream)))))))

;; These are used by com-apropos to filter the list of symbols according to the domain keyword
(defgeneric apropos-applicable-p (spec symbol))

(defmethod apropos-applicable-p ((spec (eql 'symbols)) symbol) t)

(defmethod apropos-applicable-p ((spec (eql 'classes)) symbol)
  (find-class symbol nil))  

(defmethod apropos-applicable-p ((spec (eql 'functions)) symbol)
  (fboundp symbol))

(defmethod apropos-applicable-p ((spec (eql 'variables)) symbol)
  (boundp symbol))

(defmethod apropos-applicable-p ((spec (eql 'command-tables)) symbol)
  (find-command-table symbol :errorp nil))

;(defmethod apropos-applicable-p ((spec (eql 'presentation-type)) symbol)
;  (find-presentation-type-class symbol nil))

(define-command (com-apropos :name "Apropos"
			     :command-table lisp-commands
                             :menu t
			     :provide-output-destination-keyword t)
    ((string 'clim:string :prompt "string")
     &key
     (package '(or package-name package) :prompt "in package" :default nil)
     (domain '(member symbols classes functions variables command-tables) :prompt "domain" :default 'symbols))
  (let ((real-package (when package
                        (if (typep package 'package)
                            package
                            (find-package package)))))
    (when (and package (not real-package))
      (cerror "Search all packages instead" "No package specified by ~A could be found." package))
    (let ((symbols (remove-if-not (lambda (sym) (apropos-applicable-p domain sym))
                                  (apropos-list string real-package))))
      (dolist (sym symbols)
        (apropos-present-symbol sym *standard-output* T)
        (terpri))
      (setf *apropos-list* symbols)
      (note "Results have been saved to ~W~%" '*APROPOS-LIST*))))

(define-command (com-trace :name "Trace"
			   :command-table lisp-commands
                           :menu t
			   :provide-output-destination-keyword nil)
    ((fsym 'function-name :prompt "function-name"))
  (if (fboundp fsym)
      (progn 
	(eval `(trace ,fsym))
	(format T "~&Tracing ~W.~%" fsym))
    (format T "~&Function ~W is not defined.~%" fsym)))

(define-command (com-untrace :name "Untrace"
			     :command-table lisp-commands
                             :menu t
			     :provide-output-destination-keyword nil)
    ((fsym 'symbol :prompt "function name"))
  (if (fboundp fsym)
      (progn
	(eval `(untrace ,fsym))
	(format T "~&~W will no longer be traced.~%" fsym))
    (format T "~&Function ~W is not defined.~%" fsym)))


(define-command (com-load-file :name "Load File"
                               :command-table lisp-commands
                               :menu t
			       :provide-output-destination-keyword t)
  ((pathname 'pathname :prompt "pathname"))
  (load pathname))

(define-command (com-compile-file :name "Compile File"
                                  :command-table lisp-commands
                                  :menu t
				  :provide-output-destination-keyword t)
  ((pathname 'pathname :prompt "pathname"))
  (compile-file pathname))

(define-command (com-compile-and-load :name "Compile and load"
                                      :command-table lisp-commands
                                      :menu t
				      :provide-output-destination-keyword t)
  ((pathname 'pathname :prompt "pathname"))
  (load (compile-file pathname)))

(define-command (com-room :name "Room"
                          :command-table lisp-commands
                          :menu t
			  :provide-output-destination-keyword t)
  ()
  (room))

(define-presentation-to-command-translator mem-room-translator
  (lisp-memory-usage com-room lisp-commands
                     :gesture :select
                     :documentation "Room"
                     :pointer-documentation "Room")
  ())
  

(define-presentation-to-command-translator com-show-class-subclasses-translator
  (class-name com-show-class-subclasses lisp-commands
              :menu t
              :documentation "Show Class Subclasses"
              :pointer-documentation "Show Class Subclasses")
  (presentation)
  (list (presentation-object presentation)))


(define-presentation-to-command-translator com-show-class-superclasses-translator
  (class-name com-show-class-superclasses lisp-commands
              :menu t
              :tester ((presentation)
                       (not (eq t (presentation-object presentation))))
              :documentation "Show Class Superclasses"
              :pointer-documentation "Show Class Superclasses")
  (presentation)
  (list (presentation-object presentation)))


(define-presentation-to-command-translator com-show-class-generic-functions-translator
  (class-name com-show-class-generic-functions lisp-commands
              :menu t
              :documentation "Show Class Generic Functions"
              :pointer-documentation "Show Class Generic Functions")
  (presentation)
  (list (presentation-object presentation)))


(define-presentation-to-command-translator com-show-class-slots-translator
  (class-name com-show-class-slots lisp-commands
              :menu t
              :documentation "Show Class Slots"
              :pointer-documentation "Show Class Slots")
  (presentation)
  (list (presentation-object presentation)))


;;; CLOS introspection commands

(defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72))
(defparameter *graph-text-style* (make-text-style :fix :roman :normal))

(defun class-grapher (stream class inferior-fun &key (orientation :horizontal))
  "Does the graphing for Show Class Superclasses and Subclasses commands"
  (let ((normal-ink +foreground-ink+)
        (arrow-ink  *graph-edge-ink*)
	(text-style *graph-text-style*))
    (with-drawing-options (stream :text-style text-style)
      (prog1
	;; not sure whether anyone wants the return value...
	(format-graph-from-roots (list class)
				 #'(lambda (class stream)
				     (with-drawing-options (stream :ink normal-ink
								   :text-style text-style)
				       ;; Present class name rather than class here because the printing of the
				       ;; class object itself is rather long and freaks out the pointer doc pane.
				       (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name)
					; (surrounding-output-with-border (stream :shape :drop-shadow)
					 (princ (clim-mop:class-name class) stream)))) ;)
				 inferior-fun
				 :stream stream
				 :merge-duplicates T
				 :graph-type :tree
				 :orientation orientation
				 :arc-drawer
				 #'(lambda (stream foo bar x1 y1 x2 y2)
				     (declare (ignore foo bar))
				     (draw-arrow* stream x1 y1 x2 y2 :ink arrow-ink)))
	;; format-graph-from-roots doesn't do this by default...
	(when (typep stream 'pane)
	  (change-space-requirements stream))))))

(defun frob-to-class (spec)
  (if (typep spec 'class)
      spec
    (find-class spec nil)))

(define-command (com-show-class-superclasses :name "Show Class Superclasses"
                                             :command-table show-commands
                                             :menu "Class Superclasses"
					     :provide-output-destination-keyword t)
    ((class-spec 'class-name :prompt "class")
     &key
     (orientation 'keyword :prompt "orientation" :default :horizontal))
  (let ((class (frob-to-class class-spec)))
    (if (null class)
	(note "~A is not a defined class." class-spec)
        (class-grapher *standard-output* class #'clim-mop:class-direct-superclasses
                       :orientation orientation))))

(define-command (com-show-class-subclasses :name "Show Class Subclasses"
                                           :command-table show-commands
                                           :menu "Class Subclasses"
					   :provide-output-destination-keyword t)
{'fraction_non_alphanumeric': 0.12415391994883547, 'fraction_numerical': 0.004556840590523904, 'mean_word_length': 2.517716535433071, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 11, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 64, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3493500', 'n_tokens_mistral': 11359, 'n_tokens_neox': 10540, 'n_words': 3092}