emacs/lisp/emacs-lisp/eieio-custom.el

;;; eieio-custom.el -- eieio object customization  -*- lexical-binding:t -*-

;; Copyright (C) 1999-2001, 2005, 2007-2016 Free Software Foundation,
;; Inc.

;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Old-Version: 0.2 (using "Version:" made Emacs think this is package
;;                   eieio-0.2).
;; Keywords: OO, lisp
;; Package: eieio

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs 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 General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;;   This contains support customization of eieio objects.  Enabling
;; your object to be customizable requires use of the slot attribute
;; `:custom'.

(require 'eieio)
(require 'widget)
(require 'wid-edit)
(require 'custom)

;;; Compatibility

;; (eval-and-compile
;;   (if (featurep 'xemacs)
;;       (defalias 'eieio-overlay-lists (lambda () (list (extent-list))))
;;     (defalias 'eieio-overlay-lists 'overlay-lists)))

;;; Code:
(defclass eieio-widget-test-class nil
  ((a-string :initarg :a-string
	     :initform "The moose is loose"
	     :custom string
	     :label "Amorphous String"
	     :group (default foo)
	     :documentation "A string for testing custom.
This is the next line of documentation.")
   (listostuff :initarg :listostuff
	       :initform ("1" "2" "3")
	       :type list
	       :custom (repeat (string :tag "Stuff"))
	       :label "List of Strings"
	       :group foo
	       :documentation "A list of stuff.")
   (uninitialized :initarg :uninitialized
		  :type string
		  :custom string
		  :documentation "This slot is not initialized.
Used to make sure that custom doesn't barf when it encounters one
of these.")
   (a-number :initarg :a-number
	     :initform 2
	     :custom integer
	     :documentation "A number of thingies."))
  "A class for testing the widget on.")

(defcustom eieio-widget-test (eieio-widget-test-class)
  "Test variable for editing an object."
  :type 'object
  :group 'eieio)

(defface eieio-custom-slot-tag-face '((((class color)
					(background dark))
				       (:foreground "light blue"))
				      (((class color)
					(background light))
				       (:foreground "blue"))
				      (t (:italic t)))
  "Face used for unpushable variable tags."
  :group 'custom-faces)

(defvar eieio-wo nil
  "Buffer local variable in object customize buffers for the current widget.")
(defvar eieio-co nil
  "Buffer local variable in object customize buffers for the current obj.")
(defvar eieio-cog nil
  "Buffer local variable in object customize buffers for the current group.")

 (defvar eieio-custom-ignore-eieio-co nil
   "When true, all customizable slots of the current object are updated.
Updates occur regardless of the current customization group.")

(define-widget 'object-slot 'group
  "Abstractly modify a single slot in an object."
  :tag "Slot"
  :format "%t %v%h\n"
  :convert-widget 'widget-types-convert-widget
  :value-create 'eieio-slot-value-create
  :value-get 'eieio-slot-value-get
  :value-delete 'widget-children-value-delete
  :validate 'widget-children-validate
  :match 'eieio-object-match ;; same
  )

(defun eieio-slot-value-create (widget)
  "Create the value of WIDGET."
  (let ((chil nil))
    (setq chil (cons
		(widget-create-child-and-convert
		 widget (widget-get widget :childtype)
		 :tag ""
		 :value (widget-get widget :value))
		chil))
    (widget-put widget :children chil)))

(defun eieio-slot-value-get (widget)
  "Get the value of WIDGET."
  (widget-value (car (widget-get widget :children))))

(defun eieio-custom-toggle-hide (widget)
  "Toggle visibility of WIDGET."
  (let ((vc (car (widget-get widget :children))))
    (cond ((eq (widget-get vc :eieio-custom-state) 'hidden)
	   (widget-put vc :eieio-custom-state 'visible)
	   (widget-put vc :value-face (widget-get vc :orig-face)))
	  (t
	   (widget-put vc :eieio-custom-state 'hidden)
	   (widget-put vc :orig-face (widget-get vc :value-face))
	   (widget-put vc :value-face 'invisible)
	   ))
    (widget-value-set vc (widget-value vc))))

(defun eieio-custom-toggle-parent (widget &rest _)
  "Toggle visibility of parent of WIDGET.
Optional argument IGNORE is an extraneous parameter."
  (eieio-custom-toggle-hide (widget-get widget :parent)))

(define-widget 'object-edit 'group
  "Abstractly modify a CLOS object."
  :tag "Object"
  :format "%v"
  :convert-widget 'widget-types-convert-widget
  :value-create 'eieio-object-value-create
  :value-get 'eieio-object-value-get
  :value-delete 'widget-children-value-delete
  :validate 'widget-children-validate
  :match 'eieio-object-match
  :clone-object-children nil
  )

(defun eieio-object-match (_widget _value)
  "Match info for WIDGET against VALUE."
  ;; Write me
  t)

(defun eieio-filter-slot-type (widget slottype)
  "Filter WIDGETs SLOTTYPE."
  (if (widget-get widget :clone-object-children)
      slottype
    (cond ((eq slottype 'object)
	   'object-edit)
	  ((and (listp slottype)
		(eq (car slottype) 'object))
	   (cons 'object-edit (cdr slottype)))
	  ((equal slottype '(repeat object))
	   '(repeat object-edit))
	  ((and (listp slottype)
		(equal (car slottype) 'repeat)
		(listp (car (cdr slottype)))
		(equal (car (car (cdr slottype))) 'object))
	   (list 'repeat
		 (cons 'object-edit
		       (cdr (car (cdr slottype))))))
	  (t slottype))))

(defun eieio-object-value-create (widget)
  "Create the value of WIDGET."
  (if (not (widget-get widget :value))
      (widget-put widget
		  :value (cond ((widget-get widget :objecttype)
				(funcall (eieio--class-constructor
					  (widget-get widget :objecttype))
					 "Custom-new"))
			       ((widget-get widget :objectcreatefcn)
				(funcall (widget-get widget :objectcreatefcn)))
			       (t (error "No create method specified")))))
  (let* ((chil nil)
	 (obj (widget-get widget :value))
	 (master-group (widget-get widget :eieio-group))
	 (cv (eieio--object-class obj))
	 (slots (eieio--class-slots cv)))
    ;; First line describes the object, but may not editable.
    (if (widget-get widget :eieio-show-name)
	(setq chil (cons (widget-create-child-and-convert
			  widget 'string :tag "Object "
			  :sample-face 'bold
			  (eieio-object-name-string obj))
			 chil)))
    ;; Display information about the group being shown
    (when master-group
      (let ((groups (eieio--class-option (eieio--object-class obj)
                                         :custom-groups)))
	(widget-insert "Groups:")
	(while groups
	  (widget-insert "  ")
	  (if (eq (car groups) master-group)
	      (widget-insert "*" (capitalize (symbol-name master-group)) "*")
	    (widget-create 'push-button
			   :thing (cons obj (car groups))
			   :notify (lambda (widget &rest _)
				     (eieio-customize-object
				      (car (widget-get widget :thing))
				      (cdr (widget-get widget :thing))))
			   (capitalize (symbol-name (car groups)))))
	  (setq groups (cdr groups)))
	(widget-insert "\n\n")))
    ;; Loop over all the slots, creating child widgets.
    (dotimes (i (length slots))
      (let* ((slot (aref slots i))
             (sname (eieio-slot-descriptor-name slot))
             (props (cl--slot-descriptor-props slot)))
        ;; Output this slot if it has a customize flag associated with it.
        (when (and (alist-get :custom props)
                   (or (not master-group)
                       (member master-group (alist-get :group props)))
                   (slot-boundp obj (cl--slot-descriptor-name slot)))
          ;; In this case, this slot has a custom type.  Create its
          ;; children widgets.
          (let ((type (eieio-filter-slot-type widget (alist-get :custom props)))
                (stuff nil))
            ;; This next bit is an evil hack to get some EDE functions
            ;; working the way I like.
            (if (and (listp type)
                     (setq stuff (member :slotofchoices type)))
                (let ((choices (eieio-oref obj (car (cdr stuff))))
                      (newtype nil))
                  (while (not (eq (car type) :slotofchoices))
                    (setq newtype (cons (car type) newtype)
                          type (cdr type)))
                  (while choices
                    (setq newtype (cons (list 'const (car choices))
                                        newtype)
                          choices (cdr choices)))
                  (setq type (nreverse newtype))))
            (setq chil (cons (widget-create-child-and-convert
                              widget 'object-slot
                              :childtype type
                              :sample-face 'eieio-custom-slot-tag-face
                              :tag
                              (concat
                               (make-string
                                (or (widget-get widget :indent) 0)
                                ?\s)
                               (or (alist-get :label props)
                                   (let ((s (symbol-name
                                             (or
                                              (eieio--class-slot-initarg
                                               (eieio--object-class obj)
					       sname)
					      sname))))
                                     (capitalize
                                      (if (string-match "^:" s)
                                          (substring s (match-end 0))
                                        s)))))
                              :value (slot-value obj sname)
                              :doc  (or (alist-get :documentation props)
                                        "Slot not Documented.")
                              :eieio-custom-visibility 'visible
                              )
                             chil))
            ))))
    (widget-put widget :children (nreverse chil))
    ))

(defun eieio-object-value-get (widget)
  "Get the value of WIDGET."
  (let* ((obj (widget-get widget :value))
	 (master-group eieio-cog)
	 (wids (widget-get widget :children))
	 (name (if (widget-get widget :eieio-show-name)
		   (car (widget-apply (car wids) :value-inline))
		 nil))
	 (chil (if (widget-get widget :eieio-show-name)
		   (nthcdr 1 wids) wids))
	 (cv (eieio--object-class obj))
         (i 0)
	 (slots (eieio--class-slots cv)))
    ;; If there are any prefix widgets, clear them.
    ;; -- None yet
    ;; Create a batch of initargs for each slot.
    (while (and (< i (length slots)) chil)
      (let* ((slot (aref slots i))
             (props (cl--slot-descriptor-props slot))
             (cust (alist-get :custom props)))
	;;
	;; Shouldn't I be incremented unconditionally?  Or
	;; better shouldn't we simply mapc on the slots vector
	;; avoiding use of this integer variable?  PLN Sat May
	;; 2 07:35:45 2015
	;;
	(setq i (+ i 1))
        (if (and cust
                 (or eieio-custom-ignore-eieio-co
                     (not master-group)
                     (member master-group (alist-get :group props)))
	       (slot-boundp obj (cl--slot-descriptor-name slot)))
            (progn
              ;; Only customized slots have widgets
              (let ((eieio-custom-ignore-eieio-co t))
                (eieio-oset obj (cl--slot-descriptor-name slot)
                            (car (widget-apply (car chil) :value-inline))))
              (setq chil (cdr chil))))))
    ;; Set any name updates on it.
    (if name (eieio-object-set-name-string obj name))
    ;; This is the same object we had before.
    obj))

(cl-defmethod eieio-done-customizing ((_obj eieio-default-superclass))
  "When applying change to a widget, call this method.
This method is called by the default widget-edit commands.
User made commands should also call this method when applying changes.
Argument OBJ is the object that has been customized."
  nil)

;;;###autoload
(defun customize-object (obj &optional group)
  "Customize OBJ in a custom buffer.
Optional argument GROUP is the sub-group of slots to display."
  (eieio-customize-object obj group))

(defvar eieio-custom-mode-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map widget-keymap)
    map)
  "Keymap for EIEIO Custom mode")

(define-derived-mode eieio-custom-mode fundamental-mode "EIEIO Custom"
  "Major mode for customizing EIEIO objects.
\\{eieio-custom-mode-map}")

(cl-defmethod eieio-customize-object ((obj eieio-default-superclass)
				   &optional group)
  "Customize OBJ in a specialized custom buffer.
To override call the `eieio-custom-widget-insert' to just insert the
object widget.
Optional argument GROUP specifies a subgroup of slots to edit as a symbol.
These groups are specified with the `:group' slot flag."
  ;; Insert check for multiple edits here.
  (let* ((g (or group 'default)))
    (switch-to-buffer (get-buffer-create
		       (concat "*CUSTOMIZE "
			       (eieio-object-name obj) " "
			       (symbol-name g) "*")))
    (setq buffer-read-only nil)
    (kill-all-local-variables)
    (eieio-custom-mode)
    (erase-buffer)
    (let ((all (overlay-lists)))
      ;; Delete all the overlays.
      (mapc 'delete-overlay (car all))
      (mapc 'delete-overlay (cdr all)))
    ;; Add an apply reset option at the top of the buffer.
    (eieio-custom-object-apply-reset obj)
    (widget-insert "\n\n")
    (widget-insert "Edit object " (eieio-object-name obj) "\n\n")
    ;; Create the widget editing the object.
    (make-local-variable 'eieio-wo)
    (setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g))
    ;;Now generate the apply buttons
    (widget-insert "\n")
    (eieio-custom-object-apply-reset obj)
    ;; Now initialize the buffer
    (widget-setup)
    ;;(widget-minor-mode)
    (goto-char (point-min))
    (widget-forward 3)
    (make-local-variable 'eieio-co)
    (setq eieio-co obj)
    (make-local-variable 'eieio-cog)
    (setq eieio-cog g)))

(cl-defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass))
  "Insert an Apply and Reset button into the object editor.
Argument OBJ is the object being customized."
  (widget-create 'push-button
		 :notify (lambda (&rest _)
			   (widget-apply eieio-wo :value-get)
			   (eieio-done-customizing eieio-co)
			   (bury-buffer))
		 "Accept")
  (widget-insert "   ")
  (widget-create 'push-button
		 :notify (lambda (&rest _)
			   ;; I think the act of getting it sets
			   ;; its value through the get function.
			   (message "Applying Changes...")
			   (widget-apply eieio-wo :value-get)
			   (eieio-done-customizing eieio-co)
			   (message "Applying Changes...Done"))
		 "Apply")
  (widget-insert "   ")
  (widget-create 'push-button
		 :notify (lambda (&rest _)
			   (message "Resetting")
			   (eieio-customize-object eieio-co eieio-cog))
		 "Reset")
  (widget-insert "   ")
  (widget-create 'push-button
		 :notify (lambda (&rest _)
			   (bury-buffer))
		 "Cancel"))

(cl-defmethod eieio-custom-widget-insert ((obj eieio-default-superclass)
				       &rest flags)
  "Insert the widget used for editing object OBJ in the current buffer.
Arguments FLAGS are widget compatible flags.
Must return the created widget."
  (apply 'widget-create 'object-edit :value obj flags))

(define-widget 'object 'object-edit
  "Instance of a CLOS class."
  :format "%{%t%}:\n%v"
  :value-to-internal 'eieio-object-value-to-abstract
  :value-to-external 'eieio-object-abstract-to-value
  :clone-object-children t
  )

(defun eieio-object-value-to-abstract (_widget value)
  "For WIDGET, convert VALUE to an abstract /safe/ representation."
  (if (eieio-object-p value) value))

(defun eieio-object-abstract-to-value (_widget value)
  "For WIDGET, convert VALUE from an abstract /safe/ representation."
  value)


;;; customization group functions
;;
;; These functions provide the ability to create dynamic menus to
;; customize specific sections of an object.  They do not hook directly
;; into a filter, but can be used to create easymenu vectors.
(cl-defmethod eieio-customize-object-group ((obj eieio-default-superclass))
  "Create a list of vectors for customizing sections of OBJ."
  (mapcar (lambda (group)
	    (vector (concat "Group " (symbol-name group))
		    (list 'customize-object obj (list 'quote group))
		    t))
	  (eieio--class-option (eieio--object-class obj) :custom-groups)))

(defvar eieio-read-custom-group-history nil
  "History for the custom group reader.")

(cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass))
  "Do a completing read on the name of a customization group in OBJ.
Return the symbol for the group, or nil"
  (let ((g (eieio--class-option (eieio--object-class obj)
                                :custom-groups)))
    (if (= (length g) 1)
	(car g)
      ;; Make the association list
      (setq g (mapcar (lambda (g) (cons (symbol-name g) g)) g))
      (cdr (assoc
	    (completing-read (concat (oref obj name)  " Custom Group: ")
			     g nil t nil 'eieio-read-custom-group-history)
	    g)))))

(provide 'eieio-custom)

;; Local variables:
;; generated-autoload-file: "eieio.el"
;; End:

;;; eieio-custom.el ends here