Megatest

Diff
Login

Differences From Artifact [c7090ca2ad]:

To Artifact [41f87e4841]:


106
107
108
109
110
111
112






113
114
115
116
117
118
119
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125







+
+
+
+
+
+







(define *verbosity* (cond
		     ((args:get-arg "-debug")(string->number (args:get-arg "-debug")))
		     ((args:get-arg "-v")    2)
		     ((args:get-arg "-q")    0)
		     (else                   1)))

(define uidat #f)

(define-inline (dboard:uidat-get-keycol  vec)(vector-ref vec 0))
(define-inline (dboard:uidat-get-lftcol  vec)(vector-ref vec 1))
(define-inline (dboard:uidat-get-header  vec)(vector-ref vec 2))
(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3))

;; (megatest-dashboard)

;(define img1 (iup:image/palette 16 16 (u8vector->blob (u8vector
;				   1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 
;				   1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 
;				   1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 
;				   1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 
223
224
225
226
227
228
229
230

231
232
233
234
235
236
237
229
230
231
232
233
234
235

236
237
238
239
240
241
242
243







-
+







	    maxtests))
	*num-tests*))) ;; FIXME, naughty coding eh?

(define *collapsed* (make-hash-table))
; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj)

(define (toggle-hide lnum) ; fulltestname)
  (let* ((btn (vector-ref (vector-ref uidat 0) lnum))
  (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
	 (fulltestname (iup:attribute btn "TITLE"))
	 (parts        (string-split fulltestname "("))
	 (basetestname (if (null? parts) "" (car parts))))
    ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f))
    (if (hash-table-ref/default *collapsed* basetestname #f)
	(begin
	  ;(iup:attribute-set! btn "FGCOLOR" "0 0 0")
290
291
292
293
294
295
296

297

298
299
300
301
302
303
304

305
306
307
308
309
310
311

312
313
314



315

316
317
318
319
320
321
322
296
297
298
299
300
301
302
303

304
305
306
307
308
309


310
311
312



313
314
315
316
317
318
319
320
321

322
323
324
325
326
327
328
329







+
-
+





-
-
+


-
-
-


+



+
+
+
-
+







    ;;     		 (if (equal? (car partsa)(car partsb)) ;; same test
    ;;     		     (> lenb lena)
    ;;     		     #t)
    ;;     		 #t))))))
			     
(define (update-labels uidat)
  (let* ((rown    0)
	 (keycol  (dboard:uidat-get-keycol uidat))
	 (lftcol  (vector-ref uidat 0))
	 (lftcol  (dboard:uidat-get-lftcol uidat))
	 (numcols (vector-length lftcol))
	 (maxn    (- numcols 1))
	 (allvals (make-vector numcols "")))
    (for-each (lambda (name)
		(if (<= rown maxn)
		    (let ((labl (vector-ref lftcol rown)))
		      (vector-set! allvals rown name)))
		    (vector-set! allvals rown name)) ;)
		(set! rown (+ 1 rown)))
	      *alltestnamelst*)
	;      (if (> (length *alltestnamelst*) *start-test-offset*)
	;	  (drop *alltestnamelst* *start-test-offset*)
	;	  '()))
    (let loop ((i 0))
      (let* ((lbl    (vector-ref lftcol i))
	     (keyval (vector-ref keycol i))
	     (oldval (iup:attribute lbl "TITLE"))
	     (newval (vector-ref allvals i)))
	(if (not (equal? oldval newval))
	    (let ((munged-val (let ((parts (string-split newval "(")))
				(if (> (length parts) 1)(conc "  " (car (string-split (cadr parts) ")"))) newval))))
	      (vector-set! keycol i newval)
	    (iup:attribute-set! lbl "TITLE" newval))
	      (iup:attribute-set! lbl "TITLE" munged-val)))
	(iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0"))
	(if (< i maxn)
	    (loop (+ i 1)))))))

(define (get-color-for-state-status state status)
  (case (string->symbol state)
    ((COMPLETED)
336
337
338
339
340
341
342
343
344
345



346
347
348
349
350
351
352
343
344
345
346
347
348
349



350
351
352
353
354
355
356
357
358
359







-
-
-
+
+
+







    (else               "192 192 192")))

(define (update-buttons uidat numruns numtests)
  (if *please-update-buttons*
      (let* ((runs        (if (> (length *allruns*) numruns)
			      (take-right *allruns* numruns)
			      (pad-list *allruns* numruns)))
	     (lftcol      (vector-ref uidat 0))
	     (tableheader (vector-ref uidat 1))
	     (table       (vector-ref uidat 2))
	     (lftcol      (dboard:uidat-get-lftcol uidat))
	     (tableheader (dboard:uidat-get-header uidat))
	     (table       (dboard:uidat-get-runsvec uidat))
	     (coln        0))
	(set! *please-update-buttons* #f)
	(set! *alltestnamelst* '())
	;; create a concise list of test names
	(for-each
	 (lambda (rundat)
	   (if (vector? rundat)
436
437
438
439
440
441
442

443
444
445
446
447
448
449
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457







+







  (hash-table-set! *searchpatts* x val))

(define (make-dashboard-buttons nruns ntests keynames)
  (let* ((nkeys   (length keynames))
	 (runsvec (make-vector nruns))
	 (header  (make-vector nruns))
	 (lftcol  (make-vector ntests))
	 (keycol  (make-vector ntests))
	 (controls '())
	 (lftlst  '())
	 (hdrlst  '())
	 (bdylst  '())
	 (result  '())
	 (i       0))
    ;; controls (along bottom)
540
541
542
543
544
545
546

547
548
549
550
551
552
553
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562







+







									       ))
							 #:expand "YES" 
							 #:orientation "VERTICAL")
					   (apply iup:vbox (reverse res)))))))
       (else
	(let ((labl  (iup:button "" 
				 #:flat "YES" 
				 #:alignment "ALEFT"
				 ; #:image img1
				 ; #:impress img2
				 #:size "100x15"
				 #:fontsize "10"
				 #:action (lambda (obj)
					    (set! *last-db-update-time* 0)
					    (toggle-hide testnum))))) ;; (iup:attribute obj "TITLE"))))
604
605
606
607
608
609
610
611

612
613
614
615
616
617
618
613
614
615
616
617
618
619

620
621
622
623
624
625
626
627







-
+







	       (cons (apply iup:vbox lftlst)
		     (list 
		      (iup:vbox
		       ;; the header
		       (apply iup:hbox (reverse hdrlst))
		       (apply iup:hbox (reverse bdylst))))))
       controls)))
    (vector lftcol header runsvec)))
    (vector keycol lftcol header runsvec)))

(if (or (args:get-arg "-rows")
	(get-environment-variable "DASHBOARDROWS" ))
    (begin
        (set! *num-tests* (string->number (or (args:get-arg "-rows")
					      (get-environment-variable "DASHBOARDROWS"))))
	(update-rundat "%" *num-runs* "%" "%" '()))