Simple Tooltips Listing

;;;-*- Mode: Lisp; Package: CL-USER -*- ;; ;; Adding simple tooltips to the Object Editor ;; ;; Copyright (C) 2011 David Johnson-Davies ;; You are free to use, modify, and redistribute this code however you want, except that any modifications ;; must be clearly indicated before redistribution. There is no warranty, expressed nor implied. (defclass classic-car () ((name :initarg :name :accessor name) (year :initarg :year :type integer :documentation "Year first introduced") (cylinders :initarg :cylinders :type integer :documentation "Number of cylinders") (capacity :initarg :capacity :type integer :documentation "Engine displacement in cc"))) (defparameter *cars* (list (make-instance 'classic-car :name "Saab 96V4" :year 1967 :cylinders 4 :capacity 1498) (make-instance 'classic-car :name "Porsche 911 Carrera" :year 1984 :cylinders 6 :capacity 3200) (make-instance 'classic-car :name "MGC" :year 1967 :cylinders 6 :capacity 2912) (make-instance 'classic-car :name "Ferrari Daytona" :year 1968 :cylinders 12 :capacity 4390))) (defclass edit-window (capi:interface) ((thing :initarg :thing :accessor thing)) (:default-initargs :help-callback #'do-tooltip-help)) (defun do-tooltip-help (interface pane type key) (declare (ignorable interface pane)) (when (eq type :tooltip) (documentation (find key (clos:class-slots (class-of (thing interface))) :key 'clos:slot-definition-name) t))) (defclass field (capi:text-input-pane) ((thing :initarg :thing :accessor thing) (table :initarg :table :accessor table) (type :initarg :type :accessor fieldtype)) (:default-initargs :title-args '(:external-min-width 72) :editing-callback #'(lambda (pane type) (case type (:end (save-field pane)))))) (defun make-edit-window (thing table) (let* ((ok (make-instance 'capi:push-button :text "OK" :default-p t :callback-type :interface :selection-callback #'capi:quit-interface)) (slots-to-edit (remove-if-not #'(lambda (s) (eq (clos:slot-definition-allocation s) :instance)) (clos:class-slots (class-of thing)))) (fields (map 'list #'(lambda (slot) (let ((slotname (clos:slot-definition-name slot)) (slottype (clos:slot-definition-type slot))) (make-instance 'field :name slotname :thing thing :type slottype :table table :text (princ-to-string (slot-value thing slotname)) :title (string-capitalize slotname)))) slots-to-edit)) (layout (make-instance 'capi:column-layout :description (append fields (list ok)))) (window (make-instance 'edit-window :thing thing :title (name thing) :layout layout :best-width 320 :confirm-destroy-function #'save-field-with-focus))) (capi:display window))) (defun save-field-with-focus (w) (let ((focus (capi:pane-descendant-child-with-focus w))) (when focus (save-field focus))) t) ; for confirm-destroy (defmethod save-field ((f field)) "Called to save data from field." (let* ((thing (thing f)) (table (table f)) (slot (capi:capi-object-name f)) (value (case (fieldtype f) (integer (parse-integer (capi:text-input-pane-text f) :junk-allowed t)) (t (capi:text-input-pane-text f))))) (setf (slot-value thing slot) value) (capi:choice-update-item table thing))) (defun make-list-window (list) (let* ((table (make-instance 'capi:list-panel :items list :print-function #'name :callback-type '(:data :collection) :action-callback #'(lambda (thing table) (edit thing table)))) (window (make-instance 'capi:interface :best-width 320 :best-height 224 :title "Cars" :layout (make-instance 'capi:column-layout :description (list table))))) (capi:display window))) (defun edit (thing table) (let ((existing (find thing (capi:collect-interfaces 'edit-window) :key #'thing))) (if existing (capi:raise-interface existing) (make-edit-window thing table))))
blog comments powered by Disqus