src/standard-descriptions/edit.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-description editable ()
   4   ()
   5   (:mixinp t))
   6
   7 (define-layered-class standard-attribute
   8   :in-layer #.(defining-description 'editable)
   9   ()
  10   ((edit-attribute-p
  11     :initform :inherit
  12     :layered-accessor attribute-editp
  13     :initarg :editp
  14     :layered t)
  15    (setter
  16     :initarg :setter
  17     :layered t
  18     :accessor attribute-setter
  19     :initform nil)
  20    (attribute-editor
  21     :initarg :editor
  22     :layered t
  23     :accessor attribute-editor
  24     :initform (make-instance 'attribute-editor)
  25     :documentation "This ones a bit odd")))
  26
  27 (defmethod shared-initialize :after ((object standard-attribute)
  28                                       slots &rest args &key input &allow-other-keys)
  29
  30   (when input
  31     (setf (attribute-editor object)
  32           (apply #'make-instance (find-editor-class input)
  33                  input))))
  34
  35
  36 (defun find-editor-class (spec)
  37   (let ((class (getf spec :class))
  38         (type (getf spec :type)))
  39     (or class (when
  40                   (and type (symbolp type))
  41                 (let ((name (format nil "~A-~A" type 'attribute-editor)))
  42                   (or (unless (eq (find-package :cl)
  43                                   (symbol-package type))
  44                         (find-class (intern name (symbol-package type)) nil))
  45                       (find-class (intern name) nil)
  46                       (find-class (intern name :lol) nil)
  47                       'string-attribute-editor))))))
  48
  49 (defclass attribute-editor ()
  50     ((class :initarg :class)
  51      (type :initarg :type
  52            :initform 'string
  53            :accessor attribute-editor-type)
  54      (parser :initarg :parse-using
  55              :initform 'identity
  56              :accessor attribute-editor-parsing-function)
  57      (attributes :initarg :attributes
  58                  :initform nil
  59                  :accessor attribute-editor-attributes)
  60      (prompt :initarg :prompt
  61              :initform nil)
  62      (unbound-value
  63          :initarg :unbound-value
  64        :initform "")))
  65
  66
  67
  68 (defclass string-attribute-editor (attribute-editor) ())
  69 (defclass text-attribute-editor (string-attribute-editor) ())
  70
  71 (deftype password () 'string)
  72
  73 (defclass password-attribute-editor (string-attribute-editor) ())
  74
  75 (defclass number-attribute-editor (attribute-editor) ()
  76   (:default-initargs
  77    :parse-using 'parse-number:PARSE-NUMBER
  78    :type 'number))
  79
  80 (defun parse-attribute-value (attribute value)
  81   (funcall (attribute-editor-parsing-function
  82                     (attribute-editor attribute))
  83            value))
  84
  85 (define-layered-function display-attribute-editor (attribute)
  86   (:method (attribute)
  87     (setf (attribute-value attribute)
  88           (funcall (attribute-editor-parsing-function
  89                     (attribute-editor attribute))
  90                    (read-line)))))
  91
  92 (define-description T ()
  93   ((editp :label "Edit by Default?"
  94           :value nil
  95           :editp nil)
  96    (identity :editp nil)
  97    (type :editp nil)
  98    (class :editp nil))
  99   (:in-description editable))
 100
 101 (define-layered-method (setf attribute-value-using-object)
 102  :in-layer #.(defining-description 'editable)(value object attribute)
 103
 104  (let ((setter (attribute-setter attribute)))
 105    (if setter
 106        (funcall setter value object)
 107        (error "No setter in ~A for ~A" attribute object))))
 108
 109
 110 (define-layered-function attribute-editp (attribute)
 111   (:method (attribute) nil))
 112
 113 (define-layered-method attribute-editp
 114   :in-layer #.(defining-description 'editable)
 115   ((attribute standard-attribute))
 116   (let ((value (attribute-value attribute)))
 117   (unless (or (unbound-slot-value-p value)
 118               (typep value
 119                      (attribute-editor-type
 120                       (attribute-editor attribute))))
 121     (return-from attribute-editp nil)))
 122   (let ((edit?       (call-next-method)))
 123     (if (eq :inherit edit?)
 124         (attribute-value (find-attribute
 125                           (attribute-description attribute)
 126                           'editp))
 127         edit?)))
 128
 129
 130 (define-layered-method display-attribute-value
 131   :in-layer #.(defining-description 'editable)
 132   ((attribute standard-attribute))
 133   (if (attribute-editp attribute)
 134       (display-attribute-editor attribute)
 135       (call-next-method)))
 136
 137
 138
 139
 140
 141