Coverage report: /home/runner/work/geb/geb/src/mixins/mixins.lisp

KindCoveredAll%
expression8295 86.3
branch56 83.3
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb.mixins)
2
 
3
 (defclass pointwise-mixin () ()
4
   (:documentation "Provides the service of giving point wise
5
                    operations to classes"))
6
 
7
 (defclass direct-pointwise-mixin (pointwise-mixin) ()
8
   (:documentation "Works like POINTWISE-MIXIN, however functions on
9
                    [POINTWISE-MIXIN] will only operate on direct-slots
10
                    instead of all slots the class may contain.
11
 
12
                    Further all `DIRECT-POINTWISE-MIXIN`'s are [POINTWISE-MIXIN]'s"))
13
 
14
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
15
 ;; API for Pointwise
16
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
17
 
18
 ;; my way of coping with no meta classes by default
19
 (defgeneric pointwise-slots (obj)
20
   (:documentation "Works like C2MOP:COMPUTE-SLOTS however on the object
21
                    rather than the class")
22
   ;; should we specialize it on pointwise-mixin instead? Should all
23
   ;; objects be able to give their pointwise slots?
24
   (:method ((object standard-object))
25
     (c2mop:compute-slots (class-of object))))
26
 
27
 (defgeneric obj-equalp (object1 object2)
28
   (:documentation "Compares objects with pointwise equality. This is a
29
                    much weaker form of equality comparison than
30
                    STANDARD-OBJECT EQUALP, which does the much
31
                    stronger pointer quality")
32
   (:method ((obj1 standard-object) (obj2 standard-object))
33
     "for non pointwise objects, compute the standard equalp"
34
     (equalp obj1 obj2)))
35
 
36
 (defgeneric to-pointwise-list (obj)
37
   (:documentation "Turns a given object into a pointwise LIST. listing
38
                    the KEYWORD slot-name next to their value.")
39
   (:method ((obj pointwise-mixin))
40
     (mapcar (lambda (x)
41
               (cons (util:symbol-to-keyword x)
42
                     (slot-value obj x)))
43
             (mapcar #'c2mop:slot-definition-name
44
                     (pointwise-slots obj)))))
45
 
46
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47
 ;; Instances
48
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49
 
50
 (defmethod pointwise-slots ((object direct-pointwise-mixin))
51
   "Works like the normal POINTWISE-SLOTS however we only work on
52
    direct slot values"
53
   (c2mop:class-direct-slots (class-of object)))
54
 
55
 (defmethod obj-equalp ((obj1 pointwise-mixin) (obj2 pointwise-mixin))
56
   (and (c2mop:subclassp (type-of obj1) (type-of obj2))
57
        (obj-equalp (to-pointwise-list obj1)
58
                    (to-pointwise-list obj2))))
59
 
60
 (defmethod obj-equalp ((obj1 list) (obj2 list))
61
   (or (eq obj1 obj2)
62
       (and (consp obj1)
63
            (consp obj2)
64
            (obj-equalp (car obj1) (car obj2))
65
            (obj-equalp (cdr obj1) (cdr obj2)))))
66
 
67
 ;; I should implement it for arrays as well!
68
 (defmethod obj-equalp ((obj1 t) (obj2 t))
69
   (equalp obj1 obj2))
70
 
71
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
72
 ;; Fset comparisons
73
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
74
 
75
 (defmethod fset:compare ((x direct-pointwise-mixin) (y direct-pointwise-mixin))
76
   (fset:compare (to-pointwise-list x)
77
                 (to-pointwise-list y)))
78
 
79
 (-> map-pointwise (function pointwise-mixin) pointwise-mixin)
80
 (defun map-pointwise (function obj)
81
   (values
82
    (apply #'util:copy-instance obj
83
           (alexandria:alist-plist
84
            (mapcar (lambda (x)
85
                      (cons (car x)
86
                            (funcall function (cdr x))))
87
                    (to-pointwise-list obj))))))
88
 
89
 (-> reduce-pointwise (function pointwise-mixin t) t)
90
 (defun reduce-pointwise (function obj initial)
91
   (reduce (lambda (x y)
92
             (funcall function x (cdr y)))
93
           (to-pointwise-list obj)
94
           :initial-value initial))