| ︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
-
+
|
(use format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(import ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
|
| ︙ | | |
45
46
47
48
49
50
51
52
53
54
55
56
57
58
|
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
+
+
+
+
+
|
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))
(declare (uses dbmod))
(import (prefix dbmod dbmod:))
(declare (uses commonmod))
(import (prefix commonmod cmod:))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")
|
| ︙ | | |
429
430
431
432
433
434
435
436
437
438
439
440
441
442
|
434
435
436
437
438
439
440
441
442
443
444
445
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
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
key-vals
((last-update 0) : number) ;; last query to db got records from before last-update
((last-db-time 0) : number) ;; last timestamp on megatest.db
((data-changed #f) : boolean)
((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
(db-path #f))
;; for the new runs view lets build up a few new record types and then consolidate later
;;
;; this is a two level deep pipeline for the incoming data:
;; sql query data ==> filters ==> data for display
;;
(defstruct dboard:rdat
;; view related items
(runnum 0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over
(leftcol 0) ;; number of the leftmost visible column
(toprow 0) ;; topmost visible row
(numcols 24) ;; number of columns visible
(numrows 20) ;; number of rows visible
;; data from sql db
(keys (rmt:get-keys)) ;; to be removed when targets handling is refactored
(runs (make-sparse-vector)) ;; id => runrec
(runsbynum (make-vector 100 #f)) ;; vector num => runrec
(targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed
(tests (make-hash-table)) ;; test[/itempath] => list of test rec
;; run sql filters
(targ-sql-filt "%")
(runname-sql-filt "%")
(run-state-sql-filt "%")
(run-status-sql-filt "%")
;; test sql filter
(testname-sql-filt "%")
(itempath-sql-filt "%")
(test-state-sql-filt "%")
(test-status-sql-filt "%")
;; other sql related fields
(last-updates (make-sparse-vector 0)) ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes
;; filtered data
(cols (make-sparse-vector)) ;; columnnum => run-id
(tests (make-hash-table)) ;; test[/itempath] => (vector columnnum => test rec)
;; various
(prev-run-ids '()) ;; push previously looked at runs on this
(view-changed #f)
;; widgets
(runs-tree #f) ;;
)
(define (dboard:rdat-push-run-id rdat run-id)
(dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat))))
(defstruct dboard:runrec
id
target ;; a/b/c...
tdef ;; for future use
)
(defstruct dboard:testrec
id
runid
testname ;; test[/itempath]
state
status
start-time
duration
)
;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
(cons dboard:rundat?
(lambda (tabdat-item)
(filter
|
| ︙ | | |
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
|
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
|
-
+
|
(tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
(test-patterns-textbox #f))
(hash-table-set! tests-draw-state 'first-time #t)
;; (hash-table-set! tests-draw-state 'scalef 1)
(tests:get-full-data test-names test-records '() all-tests-registry)
(set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
;; refer to (dboard:tabcodat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
(let* ((result
(iup:vbox
(dcommon:command-execution-control tabdat)
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
#:value 200
;;
|
| ︙ | | |
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
|
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
|
;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
;; logs-tb))
;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
(define (dboard:runs-tree-browser commondat tabdat)
(let* (
(txtbox (iup:textbox #:action (lambda (val a b)
(debug:catch-and-dump
(lambda ()
;; for the Runs view we put the list of keyvals into tabdat target
;; for the Run Controls we put then update the run-command
(if b (dboard:tabdat-target-set! tabdat (string-split b "/")))
(dashboard:update-run-command tabdat))
"command-testname-selector tb action"))
#:value (dboard:test-patt->lines
(dboard:tabdat-test-patts-use tabdat))
#:expand "HORIZONTAL"
;; #:size "10x30"
))
(let* ((txtbox (iup:textbox
#:action (lambda (val a b)
(debug:catch-and-dump
(lambda ()
;; for the Runs view we put the list
;; of keyvals into tabdat target for
;; the Run Controls we put then update
;; the run-command
(if b (dboard:tabdat-target-set! tabdat
(string-split b "/")))
(dashboard:update-run-command tabdat))
"command-testname-selector tb action"))
#:value (dboard:test-patt->lines
(dboard:tabdat-test-patts-use tabdat))
#:expand "HORIZONTAL"
;; #:size "10x30"
))
(tb
(iup:treebox
#:value 0
#:title "Runs" ;; was #:name -- iup 3.19 changed
;; this... "Changed: [DEPRECATED
#:title "Runs" ;; was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute."
;; REMOVED] removed the old attribute
;; NAMEid from IupTree to avoid
;; conflict with the common attribute
;; NAME. Use the TITLEid attribute."
#:expand "YES"
#:addexpanded "YES"
#:size "10x"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
(let* ((run-path (tree:node->path obj id))
(run-id (tree-path->run-id tabdat (cdr run-path))))
;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? done below when run-id is a number
(dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path)
(iup:attribute-set! txtbox "VALUE" (string-intersperse (cdr run-path) "/"))
;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
;; done below when run-id is a number
(dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print
;; "run-path:
;; "
;; run-path)
(iup:attribute-set! txtbox "VALUE"
(string-intersperse (cdr run-path) "/"))
(dashboard:update-run-command tabdat)
(dboard:tabdat-layout-update-ok-set! tabdat #f)
(if (number? run-id)
(begin
;; capture last two in tabdat.
(dboard:tabdat-prev-run-id-set!
tabdat
(dboard:tabdat-curr-run-id tabdat))
(dboard:tabdat-curr-run-id-set! tabdat run-id)
(dboard:tabdat-view-changed-set! tabdat #t))
(debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
"treebox"))
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
)))
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:detachbox
(iup:vbox
txtbox
tb
))))
;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
;; THIS IS THE NEW ONE
;;
(define (dboard:runs-tree-new-browser commondat rdat)
(let* ((txtbox (iup:textbox
#:action (lambda (val a b)
(debug:catch-and-dump
(lambda ()
;; for the Runs view we put the list
;; of keyvals into tabdat target for
;; the Run Controls we put then update
;; the run-command
(if b (dboard:rdat-targ-sql-filt-set! rdat
(string-split b "/")))
#;(dashboard:update-run-command tabdat))
"command-testname-selector tb action"))
;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from?
;; (dboard:tabdat-test-patts-use tabdat))
#:expand "HORIZONTAL"
;; #:size "10x30"
))
(tb
(iup:treebox
#:value 0
#:title "Runs" ;; was #:name -- iup 3.19 changed
;; this... "Changed: [DEPRECATED
;; REMOVED] removed the old attribute
;; NAMEid from IupTree to avoid
;; conflict with the common attribute
;; NAME. Use the TITLEid attribute."
#:expand "YES"
#:addexpanded "YES"
#:size "10x"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
(let* ((run-path (tree:node->path obj id))
(run-id (new-tree-path->run-id rdat (cdr run-path))))
;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
;; done below when run-id is a number
(dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print
;; "run-path:
;; "
;; run-path)
(iup:attribute-set! txtbox "VALUE"
(string-intersperse (cdr run-path) "/"))
#;(dashboard:update-run-command tabdat)
#;(dboard:tabdat-layout-update-ok-set! tabdat #f)
(if (number? run-id)
(begin
;; capture last two in tabdat.
(dboard:rdat-push-run-id rdat run-id)
(dboard:rdat-view-changed-set! rdat #t))
(debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
"treebox"))
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
)))
(dboard:rdat-runs-tree-set! rdat tb)
(iup:detachbox
(iup:vbox
txtbox))))
txtbox
tb
))))
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
|
| ︙ | | |
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
|
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
|
+
+
+
+
+
|
;;
;; display and manage a single run at a time
(define (tree-path->run-id tabdat path)
(if (not (null? path))
(hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
(define (new-tree-path->run-id rdat path)
(if (not (null? path))
(hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
#f))
;; (define (dboard:get-tests-dat tabdat run-id last-update)
;; (let* ((access-mode (dboard:tabdat-access-mode tabdat))
;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
;; run-id
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '()
|
| ︙ | | |
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
|
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
(iup:attribute-set! obj "MAX" (* maxruns 10))))
#:expand "HORIZONTAL"
#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
#:min 0
#:step 0.01))
;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778)
;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004)
;; simple-run-event_time procedure (x3834)
;; simple-run-event_time-set! procedure (x3830 val3831)
;; simple-run-id procedure (x3794)
;; simple-run-id-set! procedure (x3790 val3791)
;; simple-run-owner procedure (x3826)
;; simple-run-owner-set! procedure (x3822 val3823)
;; simple-run-runname procedure (x3802)
;; simple-run-runname-set! procedure (x3798 val3799)
;; simple-run-state procedure (x3810)
;; simple-run-state-set! procedure (x3806 val3807)
;; simple-run-status procedure (x3818)
;; simple-run-status-set! procedure (x3814 val3815)
;; simple-run-target procedure (x3786)
;; simple-run-target-set! procedure (x3782 val3783)
;; simple-run? procedure (x3780)
;;======================================================================
;; Extracting the data to display for runs
;;
;; This needs to be re-entrant such that it does one column per call
;; on the zeroeth call update runs data
;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded
;; on last run reset to zeroeth
;;
;; 1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration
;; - put this information into two data structures:
;; a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state,
;; status, starttime, duration, non-deleted testcount>
;; ordernum reflects order as received from sql query
;; b. sparsevec of id => runstruct
;; 2. for each run in runshash ordered by ordernum do:
;; retrieve data since last update for that run
;; if there is a deleted test - retrieve full data
;; if there are non-deleted tests register this run in the columns sparsevec
;; if this is the zeroeth column regenerate the rows sparsevec
;; if this column is in the visible zone update visible cells
;;
;; Other factors:
;; 1. left index handling:
;; - add test/itempaths to left index as discovered, re-order and
;; update row -> test/itempath mapping on each read run
;;======================================================================
;; runs is <vec header runs>
;; get ALL runs info
;; update rdat-targ-run-id
;; update rdat-runs
;;
(define (dashboard:update-runs-data rdat)
(let* ((tb (dboard:rdat-runs-tree rdat))
(targ-sql-filt (dboard:rdat-targ-sql-filt rdat))
(runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
(state-sql-filt (dboard:rdat-run-state-sql-filt rdat))
(status-sql-filt (dboard:rdat-run-status-sql-filt rdat))
;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
(data (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f))
(numruns (length data)))
;; store in the runsbynum vector
(dboard:rdat-runsbynum-set! rdat (list->vector data))
;; update runs id => runrec
;; update targ-runid target/runname => run-id
(for-each
(lambda (runrec)
(let* ((run-id (simple-run-id runrec))
(full-targ-runname (conc (simple-run-target runrec) "/"
(simple-run-runname runrec))))
(debug:print 0 *default-log-port* "Update run " run-id)
(sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
(hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id)
))
data)
numruns))
;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector
;;
(define (dashboard:update-run-data runnum rdat)
(let* ((curr-time (current-seconds))
(runrec (vector-ref (dboard:rdat-runsbynum rdat) runnum))
(run-id (simple-run-id runrec))
(last-update (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id))
;; filters
(testname-sql-filt (dboard:rdat-testname-sql-filt rdat))
;; (itempath-sql-filt (dboard:rdat-itempath-sql-filt rdat))
(test-state-sql-filt (dboard:rdat-test-state-sql-filt rdat)) ;; not used yet
(test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat)) ;; not used yet
(tests (rmt:get-tests-for-run-state-status run-id
testname-sql-filt
last-update ;; last-update
)))
(sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
(debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id "
run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update)
(length tests)))
(define (new-runs-updater commondat rdat)
(let* ((runnum (dboard:rdat-runnum rdat))
(start-time (current-milliseconds))
(tot-runs #f))
(if (eq? runnum 0)(dashboard:update-runs-data rdat))
(set! tot-runs (vector-length (dboard:rdat-runsbynum rdat)))
(let loop ((rn runnum))
(if (and (< (- (current-milliseconds) start-time) 250)
(< rn tot-runs))
(let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat)))
0 ;; start over
(+ rn 1)))) ;; (+ runnum 1)))
(dashboard:update-run-data rn rdat)
(dboard:rdat-runnum-set! rdat newrn)
(if (> newrn 0)
(loop newrn)))))
(if (>= (dboard:rdat-runnum rdat) tot-runs)
(dboard:rdat-runnum-set! rdat 0))
;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above
;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
;; (tree:add-node tb "Runs" (string-split full-targ-runname "/"))
'()))
(define (dboard:runs-new-matrix commondat rdat)
(iup:matrix
#:alignment1 "ALEFT"
;; #:expand "YES" ;; "HORIZONTAL"
#:scrollbar "YES"
#:numcol 10
#:numlin 20
#:numcol-visible 5 ;; (min 8)
#:numlin-visible 1
#:click-cb
(lambda (obj row col status)
(let* ((cell (conc row ":" col)))
#f))
))
(define (make-runs-view commondat rdat tab-num)
;; register an updater
(dboard:commondat-add-updater
commondat
(lambda ()
(new-runs-updater commondat rdat))
tab-num: tab-num)
(iup:vbox
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
#:value 100
(dboard:runs-tree-new-browser commondat rdat)
(dboard:runs-new-matrix commondat rdat)
)))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
(let* ((stats-dat (dboard:tabdat-make-data))
(runs-dat (dboard:tabdat-make-data))
(runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data))
(onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure
(runcontrols-dat (dboard:tabdat-make-data))
(runtimes-dat (dboard:tabdat-make-data))
(nruns (dboard:tabdat-numruns runs-dat))
(ntests (dboard:tabdat-num-tests runs-dat))
(keynames (dboard:tabdat-dbkeys runs-dat))
(nkeys (length keynames))
|
| ︙ | | |
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
|
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
|
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
res))
keynames)))))
(let loop ((testnum 0)
(res '()))
(cond
((>= testnum ntests)
;; now lftlst will be an hbox with the test keys and the test name labels
(set! lftlst
(append lftlst
(list (iup:hbox
(set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL"
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (string->number (iup:attribute obj "VALUE")))
(oldmax (string->number (iup:attribute obj "MAX")))
(newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
(dboard:commondat-please-update-set! commondat #t)
(dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
(debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax)
(if (< val 10)
(iup:attribute-set! obj "MAX" newmax))
))
#:expand "VERTICAL"
#:orientation "VERTICAL"
#:min 0
#:step 0.01)
(apply iup:vbox (reverse res)))))))
#:expand "HORIZONTAL"
(iup:valuator
#:valuechanged_cb (lambda (obj)
(let ((val (string->number (iup:attribute obj "VALUE")))
(oldmax (string->number (iup:attribute obj "MAX")))
(newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
(dboard:commondat-please-update-set! commondat #t)
(dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
(debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) "
(dboard:tabdat-start-test-offset runs-dat) " val: " val
" newmax: " newmax " oldmax: " oldmax)
(if (< val 10)
(iup:attribute-set! obj "MAX" newmax))
))
#:expand "VERTICAL"
#:orientation "VERTICAL"
#:min 0
#:step 0.01)
(apply iup:vbox (reverse res)))))))
(else
(let ((labl (iup:button "" ;; the testname labels
#:flat "YES"
#:alignment "ALEFT"
; #:image img1
; #:impress img2
#:size (conc cell-width btn-height)
|
| ︙ | | |
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
|
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
|
-
+
|
(apply iup:hbox (reverse hdrlst))
(apply iup:hbox (reverse bdylst))
(dashboard:runs-horizontal-slider runs-dat))))
controls
))
(views-cfgdat (common:load-views-config))
(additional-tabnames '())
(tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
(tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
;; (data (dboard:tabdat-init (make-d:data)))
(additional-views ;; process views-dat
(let ((tab-num tab-start-num)
(result '()))
(for-each
(lambda (view-name)
(debug:print 0 *default-log-port* "Adding view " view-name)
|
| ︙ | | |
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
|
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
|
+
-
+
-
-
+
+
-
-
-
+
+
+
+
|
(tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
(dboard:commondat-please-update-set! commondat #t)
(dboard:tabdat-layout-update-ok-set! tabdat #t)))
"tabchangepos"))
(dashboard:summary commondat stats-dat tab-num: 0)
runs-view
(make-runs-view commondat runs2-dat 2)
(dashboard:runs-summary commondat onerun-dat tab-num: 2)
(dashboard:runs-summary commondat onerun-dat tab-num: 3)
;; (dashboard:new-view db data new-view-dat tab-num: 3)
(dashboard:run-controls commondat runcontrols-dat tab-num: 3)
(dashboard:run-times commondat runtimes-dat tab-num: 4)
(dashboard:run-controls commondat runcontrols-dat tab-num: 4)
(dashboard:run-times commondat runtimes-dat tab-num: 5)
;; (dashboard:runs-summary commondat onerun-dat tab-num: 4)
additional-views)))
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
(iup:attribute-set! tabs "TABTITLE0" "Summary")
(iup:attribute-set! tabs "TABTITLE1" "Runs")
(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
(iup:attribute-set! tabs "TABTITLE3" "Run Control")
(iup:attribute-set! tabs "TABTITLE4" "Run Times")
(iup:attribute-set! tabs "TABTITLE2" "Runs2")
(iup:attribute-set! tabs "TABTITLE3" "Run Summary")
(iup:attribute-set! tabs "TABTITLE4" "Run Control")
(iup:attribute-set! tabs "TABTITLE5" "Run Times")
;; (iup:attribute-set! tabs "TABTITLE3" "New View")
;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")
;; set the tab names for user added tabs
(for-each
(lambda (tab-info)
(iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info)))
|
| ︙ | | |
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
|
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
|
-
-
-
-
-
-
-
-
|
fres))))
(define (dashboard:runs-tab-updater commondat tab-num)
(debug:catch-and-dump
(lambda ()
(let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
(dbkeys (dboard:tabdat-dbkeys tabdat)))
;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
;;(tabdat-values tabdat) ;;RA added
;; (pp (dboard:tabdat->alist tabdat))
;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)
;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater")
;;(inspect tabdat)
;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
|
| ︙ | | |
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
|
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
|
+
+
+
+
+
|
(dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat))
(dboard:commondat-curr-tab-num-set! commondat 0)
(dboard:commondat-add-updater
commondat
(lambda ()
(dashboard:runs-tab-updater commondat 1))
tab-num: 1)
(dboard:commondat-add-updater
commondat
(lambda ()
(dashboard:runs-tab-updater commondat 1))
tab-num: 2)
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (time-obj)
(let ((update-is-running #f))
(mutex-lock! (dboard:commondat-update-mutex commondat))
(set! update-is-running (dboard:commondat-updating commondat))
(if (not update-is-running)
|
| ︙ | | |