Coverage report: /home/runner/work/geb/geb/src/gui/show-view.lisp

KindCoveredAll%
expression0332 0.0
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb-gui)
2
 
3
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4
 ;; Main Data and View
5
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6
 
7
 (defclass show-view (view)
8
   ((counter :initform 0 :initarg :counter :accessor counter)))
9
 
10
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11
 ;; Abstractions
12
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13
 
14
 ;; Has to come before the presentation methods probably due to load order
15
 
16
 
17
 (defmacro with-presenting-alias ((obj pane) &body otherwise)
18
   "Presents an alias if it exists, otherwise"
19
   (let ((alias    (gensym))
20
         (in-there (gensym)))
21
     `(multiple-value-bind (,alias ,in-there) (geb.mixins:meta-lookup ,obj :alias)
22
        (if ,in-there
23
            (surrounding-output-with-border (,pane :shape :rectangle :background +alice-blue+)
24
              (formatting-table (,pane)
25
                (formatting-row (,pane)
26
                  (formatting-cell (,pane)
27
                    (format ,pane "~W" (intern (symbol-name ,alias)))))))
28
            (progn ,@otherwise)))))
29
 
30
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
31
 ;;;;                            Presentation                                ;;;;
32
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
33
 
34
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35
 ;; General Presentation
36
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37
 
38
 ;; TODO Abstract out the dualities better
39
 
40
 (define-presentation-method present ((object geb:prod)
41
                                      (type   geb:prod)
42
                                      (stream extended-output-stream)
43
                                      (view   show-view)
44
                                      &key)
45
   (with-presenting-alias (object stream)
46
     (surrounding-output-with-border (stream)
47
       (formatting-table (stream :x-spacing "  ")
48
         ;; dumb hack
49
         (dolist (x (serapeum:intersperse nil (geb:same-type-to-list object 'geb:prod)))
50
           (formatting-column (stream)
51
             (formatting-cell (stream :align-x :center :align-y :center)
52
               (if x
53
                   (present-object x stream)
54
                   (cross-circle stream 7.5)))))))))
55
 
56
 (define-presentation-method present ((object geb:coprod)
57
                                      (type   geb:coprod)
58
                                      (stream extended-output-stream)
59
                                      (view   show-view)
60
                                      &key)
61
   (with-presenting-alias (object stream)
62
     (surrounding-output-with-border (stream)
63
       (formatting-table (stream :x-spacing "  ")
64
         ;; dumb hack
65
         (dolist (x (serapeum:intersperse nil (geb:same-type-to-list object 'geb:coprod)))
66
           (center-column-cell (stream)
67
             (if x
68
                 (present-object x stream)
69
                 (plus-circle stream 10.5))))))))
70
 
71
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
72
 ;; Graph Presenter
73
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
74
 
75
 (define-presentation-method present ((object graph:node)
76
                                      (type graph:node)
77
                                      (pane extended-output-stream)
78
                                      (view show-view)
79
                                      &key)
80
   ;; update this to be better later
81
   (present-object (graph::value object) pane))
82
 
83
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
84
 ;; Presentation: Box View
85
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86
 
87
 
88
 (define-presentation-method present ((object geb:project-left)
89
                                      (type   geb:project-left)
90
                                      (pane   extended-output-stream)
91
                                      (view   show-view)
92
                                      &key)
93
   (with-presenting-alias (object pane)
94
     (formatting-table (pane)
95
       (center-column-cell (pane) (present-object
96
                                   (geb:prod (geb:mcar object) (geb:mcadr object))
97
                                   pane))
98
       (center-column-cell (pane) (draw-text-arrow* pane "π₁" 0 0 50 0))
99
       (center-column-cell (pane) (present-object (geb:mcar object) pane)))))
100
 
101
 (define-presentation-method present ((object geb:project-right)
102
                                      (type   geb:project-right)
103
                                      (pane   extended-output-stream)
104
                                      (view   show-view)
105
                                      &key)
106
   (with-presenting-alias (object pane)
107
     (formatting-table (pane)
108
       (center-column-cell (pane) (present-object
109
                                   (geb:prod (geb:mcar object) (geb:mcadr object))
110
                                   pane))
111
       (center-column-cell (pane) (draw-text-arrow* pane "π₂" 0 0 50 0))
112
       (center-column-cell (pane) (present-object (geb:mcadr object) pane)))))
113
 
114
 
115
 (define-presentation-method present ((object geb:inject-left)
116
                                      (type   geb:inject-left)
117
                                      (pane   extended-output-stream)
118
                                      (view   show-view)
119
                                      &key)
120
   (with-presenting-alias (object pane)
121
     (formatting-table (pane)
122
       (center-column-cell (pane) (present-object (geb:mcar object) pane))
123
       (center-column-cell (pane) (draw-text-arrow* pane "ι₁" 0 0 50 0))
124
       (center-column-cell (pane) (present-object
125
                                   (geb:coprod (geb:mcar object) (geb:mcadr object))
126
                                   pane)))))
127
 
128
 (define-presentation-method present ((object geb:inject-right)
129
                                      (type   geb:inject-right)
130
                                      (pane   extended-output-stream)
131
                                      (view   show-view)
132
                                      &key)
133
   (with-presenting-alias (object pane)
134
     (formatting-table (pane)
135
       (center-column-cell (pane) (present-object (geb:mcar object) pane))
136
       (center-column-cell (pane) (draw-text-arrow* pane "ι₂" 0 0 50 0))
137
       (center-column-cell (pane) (present-object
138
                                   (geb:coprod (geb:mcar object) (geb:mcadr object))
139
                                   pane)))))
140
 
141
 (define-presentation-method present ((object geb:terminal)
142
                                      (type   geb:terminal)
143
                                      (pane   extended-output-stream)
144
                                      (view   show-view)
145
                                      &key)
146
   (with-presenting-alias (object pane)
147
     (formatting-table (pane)
148
       (center-column-cell (pane) (present-object (geb:mcar object) pane))
149
       (center-column-cell (pane) (draw-text-arrow* pane "" 0 0 50 0))
150
       (center-column-cell (pane) (present-object geb:so1 pane)))))
151
 
152
 (define-presentation-method present ((object geb:init)
153
                                      (type   geb:init)
154
                                      (pane   extended-output-stream)
155
                                      (view   show-view)
156
                                      &key)
157
   (with-presenting-alias (object pane)
158
     (formatting-table (pane)
159
       (center-column-cell (pane) (present-object geb:so0 pane))
160
       (center-column-cell (pane) (draw-text-arrow* pane "" 0 0 50 0))
161
       (center-column-cell (pane) (present-object (geb:mcar object) pane)))))
162
 
163
 (define-presentation-method present ((object geb:distribute)
164
                                      (type   geb:distribute)
165
                                      (pane   extended-output-stream)
166
                                      (view   show-view)
167
                                      &key)
168
   (with-presenting-alias (object pane)
169
     (formatting-table (pane)
170
       (center-column-cell (pane) (present-object
171
                                   (geb:prod (geb:mcar object)
172
                                             (geb:coprod (geb:mcadr object)
173
                                                         (geb:mcaddr object)))
174
                                   pane))
175
       (center-column-cell (pane) (draw-text-arrow* pane "Dist" 0 0 50 0))
176
       (center-column-cell (pane) (present-object
177
                                   (geb:coprod (geb:prod (geb:mcar object)
178
                                                         (geb:mcadr object))
179
                                               (geb:prod (geb:mcar object)
180
                                                         (geb:mcaddr object)))
181
                                   pane)))))
182
 
183
 (define-presentation-method present ((object geb:comp)
184
                                      (type   geb:comp)
185
                                      (pane   extended-output-stream)
186
                                      (view   show-view)
187
                                      &key)
188
   (with-presenting-alias (object pane)
189
     (formatting-table (pane)
190
       (center-column-cell (pane) (present-object (geb:mcadr object) pane))
191
       (center-column-cell (pane) (draw-arrow* pane 0 0 50 0))
192
       (center-column-cell (pane) (present-object (geb:mcar object) pane)))))
193
 
194
 ;; Dumb please remove once better system #23 is in.
195
 (define-presentation-method present ((object geb:pair)
196
                                      (type   geb:pair)
197
                                      (pane   extended-output-stream)
198
                                      (view   show-view)
199
                                      &key)
200
   (with-presenting-alias (object pane)
201
     (surrounding-output-with-border (pane :shape :drop-shadow)
202
       (formatting-table (pane)
203
         (formatting-row (pane)
204
           (formatting-cell (pane :align-x :center)
205
             (format pane "Pair")))
206
         (formatting-row (pane)
207
           (formatting-cell (pane)
208
             (present-object (geb.utils:mcar object) pane)))
209
         (formatting-row (pane)
210
           (formatting-cell (pane)
211
             (present-object (geb.utils:mcdr object) pane)))))))
212
 
213
 (define-presentation-method present ((object geb:case)
214
                                      (type   geb:case)
215
                                      (pane   extended-output-stream)
216
                                      (view   show-view)
217
                                      &key)
218
   (with-presenting-alias (object pane)
219
     (surrounding-output-with-border (pane :shape :drop-shadow)
220
       (formatting-table (pane)
221
         (formatting-row (pane)
222
           (formatting-cell (pane :align-x :center)
223
             (format pane "Case")))
224
         (formatting-row (pane)
225
           (formatting-cell (pane)
226
             (present-object (geb.utils:mcar object) pane)))
227
         (formatting-row (pane)
228
           (formatting-cell (pane)
229
             (present-object (geb.utils:mcadr object) pane)))))))
230
 
231
 (define-presentation-method present ((object geb:<substmorph>)
232
                                      (type   geb:<substmorph>)
233
                                      (stream extended-output-stream)
234
                                      (view   show-view)
235
                                      &key)
236
   )
237
 
238
 (define-presentation-method present ((object geb:<substobj>)
239
                                      (type   geb:<substobj>)
240
                                      (stream extended-output-stream)
241
                                      (view   show-view)
242
                                      &key)
243
   )
244
 
245
 (define-presentation-method present ((object geb:so0)
246
                                      (type   geb:so0)
247
                                      (pane   extended-output-stream)
248
                                      (view   show-view)
249
                                      &key)
250
   (with-presenting-alias (object pane)
251
     (format pane "0")))
252
 
253
 (define-presentation-method present ((object geb:so1)
254
                                      (type   geb:so1)
255
                                      (pane   extended-output-stream)
256
                                      (view   show-view)
257
                                      &key)
258
   (with-presenting-alias (object pane)
259
     (format pane "1")))
260
 
261
 
262
 (define-presentation-method present ((object symbol)
263
                                      (type   symbol)
264
                                      (stream extended-output-stream)
265
                                      (view   show-view)
266
                                      &key))
267
 ;; todo remove
268
 (define-presentation-method present ((object string)
269
                                      (type   string)
270
                                      (stream extended-output-stream)
271
                                      (view   show-view)
272
                                      &key)
273
   (format stream object))
274
 
275
 (define-presentation-method present ((object geb.common:reference)
276
                                      (type   geb.common:reference)
277
                                      (pane   extended-output-stream)
278
                                      (view   show-view)
279
                                      &key)
280
   (surrounding-output-with-border (pane :shape :rectangle :background +alice-blue+)
281
     (formatting-table (pane)
282
       (formatting-row (pane)
283
         (formatting-cell (pane)
284
           (format pane "~W" (intern (symbol-name (geb.utils:name object)))))))))
285
 ������������