[mcclim-cvs] CVS mcclim/ESA

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/ESA
In directory clnet:/tmp/cvs-serv2026/ESA

Modified Files:
	packages.lisp utils.lisp 
Log Message:
Added support for "modes" (roughly similar to Emacs' minor-modes) to Drei.


--- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp	2007/12/19 15:10:20	1.7
+++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp	2007/12/28 10:08:52	1.8
@@ -42,11 +42,21 @@
            #:invoke-with-dynamic-bindings
            #:maptree
            #:subtype-compatible-p
+           #:capitalize
            #:observable-mixin
            #:add-observer #:remove-observer
            #:observer-notified #:notify-observers
            #:name-mixin #:name
-           #:subscriptable-name-mixin #:subscripted-name #:subscript #:subscript-generator))
+           #:subscriptable-name-mixin #:subscripted-name #:subscript #:subscript-generator
+           #:mode #:modual-mixin
+           #:available-modes
+           #:mode-directly-applicable-p #:mode-applicable-p
+           #:mode-enabled-p
+           #:enabled-modes
+           #:nonapplicable-mode
+           #:change-class-for-enabled-mode
+           #:change-class-for-disabled-mode
+           #:enable-mode #:disable-mode))
 
 (defpackage :esa
   (:use :clim-lisp :clim :esa-utils)
--- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp	2007/12/08 08:53:48	1.4
+++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp	2007/12/28 10:08:52	1.5
@@ -213,6 +213,12 @@
   (some (lambda (x)
           (subtypep x `(and , at types))) types))
 
+(defun capitalize (string)
+  "Return `string' with the first character
+capitalized (destructively modified)."
+  (setf (elt string 0) (char-upcase (elt string 0)))
+  string)
+
 (defclass observable-mixin ()
   ((%observers :accessor observers
                :initform '()))
@@ -308,3 +314,165 @@
 (defmethod (setf name) :after (new-name (name-mixin subscriptable-name-mixin))
   (setf (subscript name-mixin)
         (funcall (subscript-generator name-mixin) new-name)))
+
+;;; "Modes" are a generally useful concept, so let's define some
+;;; primitives for them here.
+
+(defclass mode ()
+  ()
+  (:documentation "A superclass for all modes."))
+
+(defclass modual-mixin ()
+  ((%original-class-name :accessor original-class-name
+                         :documentation "The original name of the
+class the `modual-mixin' is part of, the actual name will change
+as modes are added and removed."))
+  (:documentation "A mixin for objects supporting modes."))
+
+(defmethod initialize-instance :after ((object modual-mixin) &rest initargs)
+  (declare (ignore initargs))
+  (setf (original-class-name object) (class-name (class-of object))))
+
+(defgeneric available-modes (modual)
+  (:documentation "Return all available modes for `modual'. Not
+all of the modes may be applicable, use the `applicable-modes'
+function if you're only interested in these.")
+  (:method-combination append)
+  (:method append ((modual modual-mixin))
+    '()))
+
+(defgeneric mode-directly-applicable-p (modual mode-name)
+  (:documentation "Return true if the mode of the name
+`mode-name' can be directly enabled for `modual'. If the mode of
+name `mode-name' is unapplicable, an error of type
+`nonapplicable-mode' will be signalled. This allows a sort of
+\"opt-out\" where a mode can forcefully prevent another specific
+mode from being enabled. ")
+  (:method-combination or)
+  (:method or ((modual modual-mixin) mode-name)
+     nil))
+
+(defgeneric mode-applicable-p (modual mode-name)
+  (:documentation "Return true if the mode of the name
+`mode-name' can be enabled for `modual' or some sub-object of
+`modual'. If the mode of name `mode-name' is unapplicable, an
+error of type `nonapplicable-mode' will be signalled. This allows
+a sort of \"opt-out\" where a mode can forcefully prevent another
+specific mode from being enabled. ")
+  (:method-combination or)
+  (:method or ((modual modual-mixin) mode-name)
+     (mode-directly-applicable-p modual mode-name)))
+
+(defgeneric enabled-modes (modual)
+  (:documentation "Return a list of the names of the modes
+directly enabled for `modual'.")
+  (:method-combination append)
+  (:method append ((modual modual-mixin))
+     '()))
+
+(defgeneric mode-enabled-p (modual mode-name)
+  (:documentation "Return true if `mode-name' is enabled for
+`modual' or any modual \"sub-objects\"." )
+  (:method-combination or)
+  (:method or ((modual modual-mixin) mode-name)
+     (member mode-name (enabled-modes modual) :test #'equal)))
+
+(define-condition nonapplicable-mode (error)
+  ((%modual :accessor modual
+            :initarg :modual
+            :initform (error "The modual used in the error-causing operation must be supplied")
+            :documentation "The modual that the mode is attempted to be enabled for")
+   (%mode-name :accessor mode-name
+               :initarg :mode-name
+               :initform (error "The name of the problematic mode must be supplied")
+               :documentation "The name of the mode that cannot be enabled for the view"))
+  (:documentation "This error is signalled if a mode is attempted
+enabled for a modual that the mode is not applicable to.")
+  (:report (lambda (condition stream)
+             (format
+              stream "The mode ~A is not applicable for ~A"
+              (mode-name condition) (modual condition)))))
+
+(defun nonapplicable-mode (modual mode-name)
+  "Signal an error of type `nonapplicable-mode' with `modual' and
+`mode-name' as arguments."
+  (error 'nonapplicable-mode :modual modual :mode-name mode-name))
+
+(defgeneric enable-mode (modual mode-name &rest initargs)
+  (:documentation "Enable the mode of the name `mode-name' for
+`modual', using `initargs' as options for the mode. If the mode
+is already enabled, do nothing. If the mode is not applicable to
+`modual', signal an `nonapplicable-mode' error.")
+  (:method :around ((modual modual-mixin) mode-name &rest initargs)
+     (declare (ignore initargs))
+     (unless (mode-enabled-p modual mode-name)
+       (call-next-method))))
+
+(defgeneric disable-mode (modual mode-name)
+  (:documentation "Disable the mode of the name `mode-name' for
+`modual'. If a mode of the provided name is not enabled, do
+nothing.")
+  (:method :around ((modual modual-mixin) mode-name)
+     (when (mode-enabled-p modual mode-name)
+       (call-next-method))))
+
+;;; In a perfect world, we would just combine `change-class' with
+;;; anonymous classes to transparently add and remove mode classes
+;;; (the "stealth mixin" concept). However, anonymous classes are the
+;;; ugly child of CL, not well supported at all, so we'll have to do
+;;; some ugly hacks involving the `eval'ing of constructed `defclass'
+;;; forms, and caching the created classes to prevent memory leaking.
+
+(defvar *class-cache* (make-hash-table :test #'equal)
+  "A hash table mapping the name of a \"modual\" class to a
+second hash table. This second hash table maps a list of mode
+names to a class implementing this particular set of modes for
+the modual class. Note that the order in which the modes appear
+in the list is significant.")
+
+(defun make-class-implementing-modes (modual modes)
+  "Generate a class that is a subclass of `modual' that
+implements all the modes listed as names in `modes'."
+  ;; Avert thine eyes, thy of gentle spirit.
+  (if (null modes)
+      (find-class modual)
+      (eval `(defclass ,(gensym) (,modual , at modes) ()))))
+
+(defun find-class-implementing-modes (modual modes)
+  "Find, possibly create, the class implementing `modual' (a
+class name) with `modes' (a list of mode names) as the enabled
+modes."
+  (let* ((modual-cache-hit (gethash modual *class-cache*))
+         (modes-cache-hit (and modual-cache-hit
+                               (gethash modes modual-cache-hit))))
+    (or modes-cache-hit
+        (setf (gethash modes
+                       (or modual-cache-hit
+                           (setf (gethash modual *class-cache*) 
+                                 (make-hash-table :test #'equal))))
+              (make-class-implementing-modes modual modes)))))
+
+(defun change-class-for-enabled-mode (modual mode-name &rest initargs)
+  "Change the class of `modual' so that it has a mode of name
+`mode-name', created with the provided `initargs'."
+  (apply #'change-class modual (find-class-implementing-modes
+                                (original-class-name modual)
+                                (cons mode-name (enabled-modes modual)))
+         initargs))
+
+(defun change-class-for-disabled-mode (modual mode-name)
+  "Change the class of `modual' so that it does not have a mode
+of name `mode-name'."
+  (change-class modual (find-class-implementing-modes
+                        (original-class-name modual)
+                        (remove mode-name (enabled-modes modual)
+                         :test #'equal))))
+
+(defmethod enable-mode ((modual modual-mixin) mode-name &rest initargs)
+  (if (mode-directly-applicable-p modual mode-name)
+      (apply #'change-class-for-enabled-mode modual mode-name initargs)
+      (nonapplicable-mode modual mode-name)))
+
+(defmethod disable-mode ((modual modual-mixin) mode-name)
+  (when (mode-directly-applicable-p modual mode-name)
+    (change-class-for-disabled-mode modual mode-name)))