CLIM Protocol

protocols.lisp

(in-package #:climi)

;;; Forbidden method hack

(defclass constrained-trait-method (traits::trait-method)
  ((%forbidden-methods :initarg  :forbidden-methods
                       :reader   forbidden-methods
                       :initform '())))

(defmethod traits::method-ok? ((method constrained-trait-method) parameters-and-classes)
  (multiple-value-bind (ok? reason) (call-next-method)
    (if (not ok?)
        (values nil reason)
        (if-let ((forbidden (intersection (forbidden-methods method)
                                          (subseq (traits::%applicable-primary-methods method parameters-and-classes) 0 1))))
          (values nil (list "Forbidden methods are most specific primary methods:~@:_~S" forbidden))
          t))))

(defun forbidden-method! (trait generic-function &rest specializers)
  (let* ((method       (or (find generic-function (traits:direct-methods (traits:find-trait trait))
                                 :key 'traits:name)
                           (error "method not found: ~S in ~S" generic-function trait)))
         (specializers (map 'list #'find-class specializers))
         (generic-function (fdefinition generic-function))
         (forbidden    (or (find-if (lambda (method)
                                      (and (equal specializers
                                                  (c2mop:method-specializers method))
                                           (null (method-qualifiers method))))
                                    (c2mop:generic-function-methods generic-function))
                           (error "forbidden method not found in ~S: ~S"
                                  generic-function specializers))))

    (change-class method 'constrained-trait-method :forbidden-methods (list forbidden))))

;;; 3.1 Region protocol

(traits:deftrait (region something) region-protocol ()
  (:method regionp)
  ;; predicates
  (:method region-equal ((region1 region) (region2 region)))
  (:method region-contains-region-p ((region1 region) (region2 region)))
  (:method region-contains-position-p ((region region) (x something) (y something)))
  (:method region-intersects-region-p ((region1 region) (region2 region)))
  ;; composition
  (:method region-union ((region1 region) (region2 region)))
  (:method region-intersection ((region1 region) (region2 region)))
  (:method region-difference ((region1 region) (region2 region))))

;; TODO region set protocol

(traits:deftrait (path something) path-protocol ()
  (:method pathp))

(traits:deftrait (area something) area-protocol ()
  (:method areap))

(forbidden-method! 'region-protocol 'region-difference 'everywhere-region 'region)

;;; Sheet protocol

(traits:deftrait (sheet something) sheet-protocol ()
  (:method sheetp ((sheet sheet)))

  (:method sheet-parent ((sheet sheet)))
  (:method sheet-children ((sheet sheet)))
  (:method sheet-adopt-child ((sheet sheet) (child something)))
  (:method sheet-disown-child ((sheet sheet) (child something) ;&key (errorp t)
                               ))
  (:method sheet-siblings ((sheet sheet)))
  (:method sheet-enabled-children ((sheet sheet)))
  (:method sheet-ancestor-p ((sheet sheet) (putative-ancestor something)))

  (:method raise-sheet ((sheet sheet)))
  (:method bury-sheet ((sheet sheet)))
  (:method reorder-sheets ((sheet sheet) (new-ordering something)))

  (:method sheet-enabled-p ((sheet sheet)))
  (:method (setf sheet-enabled-p) ((enabled-p sheet) (sheet something)))

  (:method sheet-viewable-p ((sheet sheet)))
  (:method sheet-occluding-sheets ((sheet sheet) (child something)))
  (:method map-over-sheets ((function sheet) (sheet something))))

(forbidden-method! 'sheet-protocol 'sheet-adopt-child 'basic-sheet 'sheet)

(forbidden-method! 'sheet-protocol 'sheet-adopt-child 'sheet-leaf-mixin 'sheet)
(forbidden-method! 'sheet-protocol 'sheet-disown-child 'sheet-leaf-mixin 'sheet)

;;; 7.3.1 Sheet Geometry Protocol

(traits:deftrait (sheet something) sheet-geometry-protocol ((sheet-protocol sheet something))
  (:method sheet-transformation ((sheet sheet)))
  (:method (setf sheet-transformation) ((new-value something) (sheet sheet)))
  (:method sheet-region ((sheet sheet)))
  (:method (setf sheet-region) ((new-value something) (sheet sheet)))
  (:method move-sheet ((sheet sheet) (x something) (y something)))
  (:method resize-sheet ((sheet sheet) (width something) (height something)))
  (:method move-and-resize-sheet ((sheet sheet) (x something) (y something) (width something) (height something)))

  (:method map-sheet-position-to-parent ((sheet sheet) (x something) (y something)))
  (:method map-sheet-position-to-child ((sheet sheet) (x something) (y something)))
  (:method map-sheet-rectangle*-to-parent ((sheet sheet) (x1 something) (y1 something) (x2 something) (y2 something)))
  (:method map-sheet-rectangle*-to-child ((sheet sheet) (x1 something) (y1 something) (x2 something) (y2 something)))
  (:method map-over-sheets-containing-position ((function something) (sheet sheet) (x something) (y something)))
  (:method map-over-sheets-overlapping-region ((function something) (sheet sheet) (region something)))

  (:method child-containing-position ((sheet sheet) (x something) (y something)))
  (:method children-overlapping-region ((sheet sheet) (region something)))
  (:method children-overlapping-rectangle* ((sheet sheet) (x1 something) (y1 something) (x2 something) (y2 something)))

  (:method sheet-delta-transformation ((sheet sheet) (ancestor something)))
  (:method sheet-allocated-region ((sheet sheet) (child something))))

(forbidden-method! 'sheet-geometry-protocol 'sheet-transformation 'basic-sheet)
(forbidden-method! 'sheet-geometry-protocol '(setf sheet-transformation) t 'basic-sheet)
(forbidden-method! 'sheet-geometry-protocol 'map-sheet-position-to-parent 'basic-sheet t t)
(forbidden-method! 'sheet-geometry-protocol 'map-sheet-position-to-child 'basic-sheet t t)
(forbidden-method! 'sheet-geometry-protocol 'map-sheet-rectangle*-to-parent 'basic-sheet t t t t)
(forbidden-method! 'sheet-geometry-protocol 'map-sheet-rectangle*-to-child 'basic-sheet t t t t)

;;; Sheet mirror protocol

(traits:deftrait (sheet port) sheet-mirror-protocol ()
  (:method sheet-direct-mirror ((sheet sheet)))
  (:method sheet-mirrored-ancestor ((sheet sheet)))
  (:method sheet-mirror  ((sheet sheet)))
  (:method realize-mirror ((port port) (mirrored-sheet sheet)))
  (:method destroy-mirror ((port port) (mirrored-sheet sheet)))
  (:method raise-mirror  ((port port) (sheet sheet)))
  (:method bury-mirror  ((port port) (sheet sheet)))
  (:method port ((sheet sheet)))        ;  basic-sheet
  )

(forbidden-method! 'sheet-mirror-protocol 'realize-mirror 'basic-port 'mirrored-sheet-mixin)
(forbidden-method! 'sheet-mirror-protocol 'destroy-mirror 'basic-port 'mirrored-sheet-mixin)
(forbidden-method! 'sheet-mirror-protocol 'realize-mirror 'basic-port 'mirrored-sheet-mixin)
; (forbidden-method! 'sheet-mirror-protocol 'mirror-transformation 'basic-port 't)

(forbidden-method! 'sheet-mirror-protocol 'realize-mirror 'basic-port 'mirrored-pixmap)
(forbidden-method! 'sheet-mirror-protocol 'destroy-mirror 'basic-port 'mirrored-pixmap)
; (forbidden-method! 'sheet-mirror-protocol 'port-allocate-pixmap 'basic-port t t t)
; (forbidden-method! 'sheet-mirror-protocol 'port-deallocate-pixmap 'basic-port t)

;;; 8.1 Input protocol

(traits:deftrait (sheet something) input-protocol ((sheet-protocol pane something))
  (:method handle-event ((client sheet) (event something))))

;;; 29.2 Pane protocol

(traits:deftrait (pane something) pane-protocol ((sheet-protocol pane something))
  (:initarg :foreground pane)
  (:initarg :background pane)
  (:initarg :text-style pane)
  (:initarg :name pane)

  (:method panep ((pane pane)))
  (:method pane-frame  ((pane pane)))
  (:method pane-name ((pane pane)))
  (:method pane-foreground ((pane pane)))
  (:method pane-background ((pane pane)))
  (:method pane-text-style ((pane pane))))

;;; 29.3 Pane composition and layout protocol

(traits:deftrait (pane something) pane-composition-protocol ((pane-protocol pane something))
  (:initarg :contents pane)
  (:initarg :width pane)
  (:initarg :max-width pane)
  (:initarg :min-width pane)
  (:initarg :height pane)
  (:initarg :max-height pane)
  (:initarg :min-height pane)
  (:initarg :align-x pane)
  (:initarg :align-y pane)
  (:initarg :x-spacing pane)
  (:initarg :y-spacing pane)
  (:initarg :spacing pane)

  )

;;; 30.3 Basic gadget protocols

(traits:deftrait (gadget something) gadget-protocol ((pane-protocol gadget something))
  (:initarg :id gadget)
  (:initarg :client gadget)
  (:initarg :armed-callback gadget)
  (:initarg :disarmed-callback gadget)
  (:initarg :active gadget)             ; non-standard?

  (:method gadgetp ((gadget gadget)))
  (:method gadget-id ((gadget gadget)))
  (:method (setf gadget-id) ((id something) (gadget gadget)))
  (:method gadget-client ((gadget gadget)))
  (:method (setf gadget-client) ((client something) (gadget gadget)))
  (:method gadget-armed-callback ((gadget gadget)))
  (:method gadget-disarmed-callback ((gadget gadget)))
  (:method armed-callback ((gadget gadget) (client something) (gadget-id something)))
  (:method disarmed-callback ((gadget gadget) (client something) (gadget-id something)))
  (:method activate-gadget ((gadget gadget)))
  (:method deactivate-gadget ((gadget gadget)))
  (:method gadget-active-p ((gadget gadget)))
  (:method note-gadget-activated ((client something) (gadget gadget)))
  (:method note-gadget-deactivated ((client something) (gadget gadget))))

;;; Value gadget protocol

(traits:deftrait (gadget something) value-gadget-protocol ((gadget-protocol gadget something))
  (:initarg :value gadget)
  (:initarg :value-changed-callback gadget)

  (:method gadget-value ((gadget gadget)))
  (:method (setf gadget-value) ((value something) (gadget gadget)))
  (:method gadget-value-changed-callback ((gadget gadget)))
  (:method value-changed-callback ((gadget gadget) (client something) (id something) (value something))))

;;; Action gadget protocol

;;; Oriented gadget protocol

;;; Labelled gadget protocol

(traits:deftrait (gadget something) labelled-gadget-protocol ((gadget-protocol gadget something))
  (:initarg :label gadget)
  (:initarg :align-x gadget)
  (:initarg :align-y gadget)

  (:method gadget-label ((gadget gadget)))
  (:method (setf gadget-label) ((new-value something) (gadget gadget)))
  (:method gadget-label-align-x ((gadget gadget)))
  (:method (setf gadget-label-align-x) ((new-value something) (gadget gadget)))
  (:method gadget-label-align-y ((gadget gadget)))
  (:method (setf gadget-label-align-y) ((new-value something) (gadget gadget))))

(progn
  (fresh-line)
  (report '((slider-pane . gadget)) 'labelled-gadget-protocol))

;;; Range gadget protocol

(traits:deftrait (gadget something) range-gadget-protocol ((value-gadget-protocol gadget something))
  (:initarg :min-value gadget)
  (:initarg :max-value gadget)

  (:method gadget-min-value ((range-gadget gadget)))
  (:method (setf gadget-min-value) ((new-value something) (range-gadget gadget)))
  (:method gadget-max-value ((range-gadget gadget)))
  (:method (setf gadget-max-value) ((new-value something) (range-gadget gadget)))
  (:method gadget-range ((range-gadget gadget)))
  (:method gadget-range* ((range-gadget gadget))))

(progn
  (fresh-line)
  (report '((slider-pane . gadget)) 'range-gadget-protocol))

;;; 30.4.2 `toggle-button' protocol

(traits:deftrait (gadget something) toggle-button-protocol ((value-gadget-protocol gadget something)) ; TODO action-gadget?
  (:initarg :indicator-type gadget)

  (:method toggle-button-indicator-type ((toggle-button gadget))))

;;; Utilities

(defun map-concrete-classes (function root)
  (let ((seen (make-hash-table :test #'eq)))
    (labels ((rec (class)
               (unless (gethash class seen)
                 (setf (gethash class seen) t)
                                        ; (funcall function class)
                 (if-let ((subclasses (c2mop:class-direct-subclasses class)))
                   (mapc #'rec subclasses)
                   (funcall function class)))))
      (rec root)))
  nil)

(defun map-port-and-sheet-classes (function)
  (map-concrete-classes
   (lambda (port-class)
     (when (eq port-class (find-class 'mcclim-truetype::clx-ttf-port))
       (let* ((port-prototype ; (make-instance port-class)
                )
              (fm-prototype (make-instance 'clim-clx::clx-frame-manager :mirroring (clim-clx::mirror-factory :single))
                            #+no (first (climi::frame-managers port-prototype))))
         (map-concrete-classes
          (lambda (sheet-class)
            (let ((sheet-class* (find-concrete-pane-class
                                 fm-prototype (class-name sheet-class))))
              (print (list sheet-class :-> sheet-class*))
              (funcall function port-class sheet-class*)))
          (find-class 'basic-sheet)))))
   (find-class 'basic-port)))

(defun report (classes-and-roles trait)
  (let ((trait (if (symbolp trait)
                   (traits:find-trait trait)
                   trait))
        (*print-right-margin* most-positive-fixnum))
    (when-let ((methods (traits::problematic-methods classes-and-roles trait)))
      (format t "~@<For ~{~A~^, ~} the following ~A methods are not implemented~@:_~
                 ~{~2@T• ~<~{~A~@[~@:_~{~@?~}~]~}~:>~^~@:_~@:_~}~
                 ~:>"
              classes-and-roles
              (traits:name trait)
              (map 'list #'list (sort (copy-seq methods) #'string<
                                      :key (alexandria:compose #'princ-to-string #'traits:name #'first)))))
    (when-let ((initargs (traits::unimplemented-initargs classes-and-roles trait)))
      (fresh-line)
      (format t "~@<For ~{~A~^, ~} the following ~A initargs are not implemented~@:_~
                 ~2@T~@<~{• ~A~^~:@_~}~@:>~
                 ~@:>"
              classes-and-roles
              (traits:name trait)
              (sort (copy-seq initargs) #'string< :key (alexandria:compose #'princ-to-string #'traits:name))))))

;;; Tests

(map-concrete-classes
 (lambda (region-class)
   (fresh-line)
   (report (list (cons region-class 'region)) 'region-protocol))
 (find-class 'region))

(defun sheet-report ()
  (map-concrete-classes
   (lambda (class)
     (terpri)
     (terpri)
     ; (report (list (cons class 'sheet)) 'sheet-geometry-protocol)
     (report (list (cons class 'sheet)) 'input-protocol))
   (find-class 'basic-sheet)))

(defun test ()
  (let ((trait (traits:find-trait 'pane-protocol)))
    (map-concrete-classes
     (lambda (pane-class)
       (with-simple-restart (continue "Next")
         (unless (traits::check-implementation pane-class 'pane trait)
           (break "~A" pane-class))))
     (find-class 'pane)))

  (let ((trait (traits:find-trait 'gadget-protocol)))
    (map-concrete-classes
     (lambda (gadget-class)
       (with-simple-restart (continue "Next")
         (unless (traits::check-implementation gadget-class 'gadget trait)
           (break "~A" gadget-class))))
     (find-class 'gadget)))

  (let ((trait (traits:find-trait 'value-gadget-protocol)))
    (map-concrete-classes
     (lambda (gadget-class)
       (with-simple-restart (continue "Next")
         (unless (traits::check-implementation gadget-class 'gadget trait)
           (break "~A" gadget-class))))
     (find-class 'value-gadget)))

  (map-concrete-classes
   (lambda (gadget-class)
     (fresh-line)
     (report (list (cons gadget-class 'gadget)) 'value-gadget-protocol))
   (find-class 'value-gadget))

  (let ((trait (traits:find-trait 'sheet-mirror-protocol)))
    (map-port-and-sheet-classes
     (lambda (port-class sheet-class)
       (when (eq port-class (find-class 'mcclim-truetype::clx-ttf-port))
        (fresh-line)
        (report (list (cons sheet-class 'sheet) (cons port-class 'port)) trait))))))

REPL

CLIMI> (defclass foo () ())
#<STANDARD-CLASS CLIM-INTERNALS::FOO>
CLIMI> (report '((foo . gadget)) 'labelled-gadget-protocol)
For (FOO . GADGET) the following LABELLED-GADGET-PROTOCOL methods are not implemented
  • TRAIT-METHOD (SETF GADGET-CLIENT) (CLIENT GADGET) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD (SETF GADGET-ID) (ID GADGET) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD (SETF GADGET-LABEL) (NEW-VALUE GADGET) [from LABELLED-GADGET-PROTOCOL trait]
  • TRAIT-METHOD (SETF GADGET-LABEL-ALIGN-X) (NEW-VALUE GADGET) [from LABELLED-GADGET-PROTOCOL trait]
  • TRAIT-METHOD (SETF GADGET-LABEL-ALIGN-Y) (NEW-VALUE GADGET) [from LABELLED-GADGET-PROTOCOL trait]
  • TRAIT-METHOD ACTIVATE-GADGET (GADGET) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD ARMED-CALLBACK (GADGET CLIENT GADGET-ID) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD BURY-SHEET (SHEET) [from SHEET-PROTOCOL trait]
  • TRAIT-METHOD DEACTIVATE-GADGET (GADGET) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD DISARMED-CALLBACK (GADGET CLIENT GADGET-ID) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD GADGET-ACTIVE-P (GADGET) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD GADGET-ARMED-CALLBACK (GADGET) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD GADGET-CLIENT (GADGET) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD GADGET-DISARMED-CALLBACK (GADGET) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD GADGET-ID (GADGET) [from GADGET-PROTOCOL trait]
  • TRAIT-METHOD GADGET-LABEL (GADGET) [from LABELLED-GADGET-PROTOCOL trait]
  • TRAIT-METHOD GADGET-LABEL-ALIGN-X (GADGET) [from LABELLED-GADGET-PROTOCOL trait]
  • TRAIT-METHOD GADGET-LABEL-ALIGN-Y (GADGET) [from LABELLED-GADGET-PROTOCOL trait]
  • TRAIT-METHOD PANE-BACKGROUND (PANE) [from PANE-PROTOCOL trait]
  • TRAIT-METHOD PANE-FOREGROUND (PANE) [from PANE-PROTOCOL trait]
  • TRAIT-METHOD PANE-FRAME (PANE) [from PANE-PROTOCOL trait]
  • TRAIT-METHOD PANE-NAME (PANE) [from PANE-PROTOCOL trait]
  • TRAIT-METHOD PANE-TEXT-STYLE (PANE) [from PANE-PROTOCOL trait]
  • TRAIT-METHOD RAISE-SHEET (SHEET) [from SHEET-PROTOCOL trait]
  • TRAIT-METHOD REORDER-SHEETS (SHEET NEW-ORDERING) [from SHEET-PROTOCOL trait]
  • CONSTRAINED-TRAIT-METHOD SHEET-ADOPT-CHILD (SHEET CHILD) [from SHEET-PROTOCOL trait]
  • TRAIT-METHOD SHEET-ANCESTOR-P (SHEET PUTATIVE-ANCESTOR) [from SHEET-PROTOCOL trait]
  • TRAIT-METHOD SHEET-CHILDREN (SHEET) [from SHEET-PROTOCOL trait]
  • CONSTRAINED-TRAIT-METHOD SHEET-DISOWN-CHILD (SHEET CHILD) [from SHEET-PROTOCOL trait]
  • TRAIT-METHOD SHEET-ENABLED-CHILDREN (SHEET) [from SHEET-PROTOCOL trait]
  • TRAIT-METHOD SHEET-ENABLED-P (SHEET) [from SHEET-PROTOCOL trait]
  • TRAIT-METHOD SHEET-OCCLUDING-SHEETS (SHEET CHILD) [from SHEET-PROTOCOL trait]
  • TRAIT-METHOD SHEET-PARENT (SHEET) [from SHEET-PROTOCOL trait]
  • TRAIT-METHOD SHEET-SIBLINGS (SHEET) [from SHEET-PROTOCOL trait]
  • TRAIT-METHOD SHEET-VIEWABLE-P (SHEET) [from SHEET-PROTOCOL trait]
For (FOO . GADGET) the following LABELLED-GADGET-PROTOCOL initargs are not implemented
  • TRAIT-INITARG ACTIVE [from GADGET-PROTOCOL trait]
  • TRAIT-INITARG ALIGN-X [from LABELLED-GADGET-PROTOCOL trait]
  • TRAIT-INITARG ALIGN-Y [from LABELLED-GADGET-PROTOCOL trait]
  • TRAIT-INITARG ARMED-CALLBACK [from GADGET-PROTOCOL trait]
  • TRAIT-INITARG BACKGROUND [from PANE-PROTOCOL trait]
  • TRAIT-INITARG CLIENT [from GADGET-PROTOCOL trait]
  • TRAIT-INITARG DISARMED-CALLBACK [from GADGET-PROTOCOL trait]
  • TRAIT-INITARG FOREGROUND [from PANE-PROTOCOL trait]
  • TRAIT-INITARG ID [from GADGET-PROTOCOL trait]
  • TRAIT-INITARG LABEL [from LABELLED-GADGET-PROTOCOL trait]
  • TRAIT-INITARG NAME [from PANE-PROTOCOL trait]
  • TRAIT-INITARG TEXT-STYLE [from PANE-PROTOCOL trait]