| ︙ | | | ︙ | |
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
|
;;
;; must select values from only apropriate targets
;; a b c
;; a d e
;; a b f
;; a/b => c f
;;
(define (dashboard:populate-target-dropdown lb referent-vals targets)
;; is the current value in the new list? choose new default if not
(let* ((remvalues (map (lambda (row)
(common:list-is-sublist referent-vals (vector->list row)))
targets))
(values (delete-duplicates (map car (filter list? remvalues))))
(sel-valnum (iup:attribute lb "VALUE"))
(sel-val (iup:attribute lb sel-valnum))
|
|
|
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
|
;;
;; must select values from only apropriate targets
;; a b c
;; a d e
;; a b f
;; a/b => c f
;;
(define (dashboard:populate-target-dropdown lb referent-vals targets) ;; runconf-targs)
;; is the current value in the new list? choose new default if not
(let* ((remvalues (map (lambda (row)
(common:list-is-sublist referent-vals (vector->list row)))
targets))
(values (delete-duplicates (map car (filter list? remvalues))))
(sel-valnum (iup:attribute lb "VALUE"))
(sel-val (iup:attribute lb sel-valnum))
|
| ︙ | | | ︙ | |
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
|
val
(if (not (null? values))
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
(let* ((db-target-dat (open-run-close db:get-targets #f))
#:action action-proc
))))
;; loop though all the targets and build the list for this dropdown
(selected-value (dashboard:populate-target-dropdown lb refvals db-targets)))
(if (null? remkeys)
;; return a list of the listbox items and an iup:hbox with the labels and listboxes
(let ((listboxes (append lbs (list lb))))
(list listboxes
(map (lambda (htxt lb)
(iup:vbox
(iup:label htxt)
lb))
header
listboxes)))
(loop (car remkeys)
(cdr remkeys)
(append refvals (list selected-value))
(+ indx 1)
|
>
|
>
>
>
>
>
>
>
>
|
>
|
|
|
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
|
val
(if (not (null? values))
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
(db-target-dat (open-run-close db:get-targets #f))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(all-targets (append db-targets
(map (lambda (x)
(list->vector
(take (append (string-split x "/")
(make-list (length header) "na"))
(length header))))
runconf-targs)))
(key-listboxes (if key-lbs key-lbs (make-list (length header) #f))))
(let loop ((key (car header))
(remkeys (cdr header))
(refvals '())
(indx 0)
(lbs '()))
(let* ((lb (let ((lb (list-ref key-listboxes indx)))
(if lb
lb
(iup:listbox
;; #:size "x10"
#:fontsize "10"
#:expand "YES" ;; "VERTICAL"
;; #:dropdown "YES"
#:editbox "YES"
#:action (lambda (obj a b c)
(action-proc))
#:caret_cb (lambda (obj a b c)(action-proc))
))))
;; loop though all the targets and build the list for this dropdown
(selected-value (dashboard:populate-target-dropdown lb refvals all-targets)))
(if (null? remkeys)
;; return a list of the listbox items and an iup:hbox with the labels and listboxes
(let ((listboxes (append lbs (list lb))))
(list listboxes
(map (lambda (htxt lb)
(iup:vbox
(iup:label htxt)
lb))
header
listboxes)))
(loop (car remkeys)
(cdr remkeys)
(append refvals (list selected-value))
(+ indx 1)
|
| ︙ | | | ︙ | |
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
|
" -target "
target
" :runname "
run-name
)))
((remove-runs)
(set! full-cmd (conc full-cmd
" -remove-runs "
run-name
" -target "
target
" -testpatt "
test-patt
states-str
statuses-str
|
|
|
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
|
" -target "
target
" :runname "
run-name
)))
((remove-runs)
(set! full-cmd (conc full-cmd
" -remove-runs :runname "
run-name
" -target "
target
" -testpatt "
test-patt
states-str
statuses-str
|
| ︙ | | | ︙ | |
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
|
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-controls)
(let* ((targets (make-hash-table))
(runconf-targs (common:get-runconfig-targets))
(update-keyvals (lambda (obj b c d)
;; (print "obj: " obj ", b " b ", c " c ", d " d)
(let ((targ (map (lambda (x)
(iup:attribute x "VALUE"))
(car (dashboard:update-target-selector key-listboxes)))))
(dboard:data-set-target! *data* targ)
(dashboard:update-run-command))))
(tests-draw-state (make-hash-table))) ;; use for keeping state of the test canvas
(hash-table-set! tests-draw-state 'first-time #t)
|
<
|
<
|
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
|
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-controls)
(let* ((targets (make-hash-table))
(test-records (make-hash-table))
(test-names (tests:get-valid-tests *toppath* '()))
(sorted-testnames #f)
(action "-runtests")
(cmdln "")
(runlogs (make-hash-table))
(key-listboxes #f)
(update-keyvals (lambda ()
(let ((targ (map (lambda (x)
(iup:attribute x "VALUE"))
(car (dashboard:update-target-selector key-listboxes)))))
(dboard:data-set-target! *data* targ)
(dashboard:update-run-command))))
(tests-draw-state (make-hash-table))) ;; use for keeping state of the test canvas
(hash-table-set! tests-draw-state 'first-time #t)
|
| ︙ | | | ︙ | |