| ︙ | | | ︙ | |
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
draw-cache ;;
start-row
run-start-row
max-row
running-layout
originx
originy
;; Controls used to launch runs etc.
command
command-tb
run-name ;; from run name setting widget
states ;; states for -state s1,s2 ...
statuses ;; statuses for -status s1,s2 ...
;; Selector variables
curr-run-id ;; current row to display in Run summary view
curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
|
>
|
>
>
|
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
draw-cache ;;
start-row
run-start-row
max-row
running-layout
originx
originy
layout-update-ok
;; Controls used to launch runs etc.
command ;; for run control this is the command being built up
command-tb
key-listboxes
key-lbs
run-name ;; from run name setting widget
states ;; states for -state s1,s2 ...
statuses ;; statuses for -status s1,s2 ...
;; Selector variables
curr-run-id ;; current row to display in Run summary view
curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
|
| ︙ | | | ︙ | |
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
|
(define (dboard:tabdat-make-data)
(let ((dat (make-dboard:tabdat
allruns-by-id: (make-hash-table)
allruns: '() ;; list of run records (vectors)
buttondat: (make-hash-table)
curr-test-ids: (make-hash-table)
dbdir: #f
filters-changed: #f
header: #f
hide-empty-runs: #f
hide-not-hide-button: #f
hide-not-hide: #t
item-test-names: '()
last-db-update: 0
last-data-update: 0
not-done-runs: '()
done-runs: '()
num-tests: 15
numruns: 16
originx: #f
originy: #f
path-run-ids: (make-hash-table)
|
>
>
>
>
|
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
|
(define (dboard:tabdat-make-data)
(let ((dat (make-dboard:tabdat
allruns-by-id: (make-hash-table)
allruns: '() ;; list of run records (vectors)
buttondat: (make-hash-table)
curr-test-ids: (make-hash-table)
command: ""
dbdir: #f
filters-changed: #f
header: #f
hide-empty-runs: #f
hide-not-hide-button: #f
hide-not-hide: #t
item-test-names: '()
keys: #f
key-listboxes: #f
last-db-update: 0
last-data-update: 0
layout-update-ok: #t
not-done-runs: '()
done-runs: '()
num-tests: 15
numruns: 16
originx: #f
originy: #f
path-run-ids: (make-hash-table)
|
| ︙ | | | ︙ | |
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
|
;; in sync.
;;
(defstruct dboard:rundat
run
tests-drawn ;; list of id's already drawn on screen
tests-notdrawn ;; list of id's NOT already drawn
rowsused ;; hash of lists covering what areas used - replace with quadtree
tests ;; hash of id => testdat
tests-by-name ;; hash of testfullname => testdat
key-vals
last-update ;; last query to db got records from before last-update
)
(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100))
(make-dboard:rundat
run: run
tests: (or tests (make-hash-table))
tests-by-name: (make-hash-table)
key-vals: key-vals
last-update: last-update)) ;; -100 is before time began
(define (dboard:rundat-copy-tests-to-by-name rundat)
(let ((src-ht (dboard:rundat-tests rundat))
(trg-ht (dboard:rundat-tests-by-name rundat)))
(if (and (hash-table? src-ht)(hash-table? trg-ht))
(for-each
(lambda (testdat)
|
>
>
|
|
>
>
|
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
|
;; in sync.
;;
(defstruct dboard:rundat
run
tests-drawn ;; list of id's already drawn on screen
tests-notdrawn ;; list of id's NOT already drawn
rowsused ;; hash of lists covering what areas used - replace with quadtree
hierdat ;; put hierarchial sorted list here
tests ;; hash of id => testdat
tests-by-name ;; hash of testfullname => testdat
key-vals
last-update ;; last query to db got records from before last-update
data-changed
)
(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100));; -100 is before time began
(make-dboard:rundat
run: run
tests: (or tests (make-hash-table))
tests-by-name: (make-hash-table)
key-vals: key-vals
last-update: last-update
data-changed: #t
))
(define (dboard:rundat-copy-tests-to-by-name rundat)
(let ((src-ht (dboard:rundat-tests rundat))
(trg-ht (dboard:rundat-tests-by-name rundat)))
(if (and (hash-table? src-ht)(hash-table? trg-ht))
(for-each
(lambda (testdat)
|
| ︙ | | | ︙ | |
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
|
(statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
(bubble-type (if (member sort-order '(testname))
'testname
'itempath))
(run-dat (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
(if rec rec (dboard:rundat-make-init run: run key-vals: key-vals))))
;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
(last-update (dboard:tabdat-last-update tabdat)) ;; (vector-ref prev-dat 3))
(tmptests (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
#f #f ;; offset limit
(dboard:tabdat-hide-not-hide tabdat) ;; no-in
sort-by ;; sort-by
sort-order ;; sort-order
#f ;; 'shortlist ;; qrytype
(if (dboard:tabdat-filters-changed tabdat)
0
last-update) ;; last-update
*dashboard-mode*)) ;; use dashboard mode
(use-new (dboard:tabdat-hide-not-hide tabdat))
(tests-ht (dboard:rundat-tests run-dat))
(start-time (current-seconds)))
(for-each
(lambda (tdat)
(let ((test-id (db:test-get-id tdat))
(state (db:test-get-state tdat)))
(if (equal? state "DELETED")
(hash-table-delete! tests-ht test-id)
(hash-table-set! tests-ht test-id tdat))))
tmptests)
(dboard:rundat-last-update-set! run-dat (- (current-seconds) 10)) ;; go back two seconds in time to ensure all changes are captured.
tests-ht))
|
>
>
>
|
>
>
>
|
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
|
(statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
(bubble-type (if (member sort-order '(testname))
'testname
'itempath))
;; note: the rundat is normally created in "update-rundat".
(run-dat (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
(if rec
rec
(let ((rd (dboard:rundat-make-init run: run key-vals: key-vals)))
(hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd)
rd))))
;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
(last-update (dboard:tabdat-last-update tabdat)) ;; (vector-ref prev-dat 3))
(tmptests (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
#f #f ;; offset limit
(dboard:tabdat-hide-not-hide tabdat) ;; no-in
sort-by ;; sort-by
sort-order ;; sort-order
#f ;; 'shortlist ;; qrytype
(if (dboard:tabdat-filters-changed tabdat)
0
last-update) ;; last-update
*dashboard-mode*)) ;; use dashboard mode
(use-new (dboard:tabdat-hide-not-hide tabdat))
(tests-ht (dboard:rundat-tests run-dat))
(start-time (current-seconds)))
(for-each
(lambda (tdat)
(let ((test-id (db:test-get-id tdat))
(state (db:test-get-state tdat)))
(dboard:rundat-data-changed-set! run-dat #t)
(if (equal? state "DELETED")
(hash-table-delete! tests-ht test-id)
(hash-table-set! tests-ht test-id tdat))))
tmptests)
(dboard:rundat-last-update-set! run-dat (- (current-seconds) 10)) ;; go back two seconds in time to ensure all changes are captured.
tests-ht))
|
| ︙ | | | ︙ | |
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
|
(if val
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 (rmt:get-targets))
(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 "45x50"
#:fontsize "10"
#:expand "YES" ;; "VERTICAL"
;; #:dropdown "YES"
#:editbox "YES"
#:action (lambda (obj a b c)
(debug:catch-and-dump action-proc "update-target-selector"))
#:caret_cb (lambda (obj a b c)
(debug:catch-and-dump action-proc "update-target-selector"))
))))
;; 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)
(append lbs (list lb))))))))
;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string
;; interspersed with commas
;;
(define (dashboard:text-list-toggle-box items proc)
(let ((alltgls (make-hash-table)))
(apply iup:vbox
(map (lambda (item)
(iup:toggle
item
#:expand "YES"
#:action (lambda (obj tstate)
(debug:catch-and-dump
(lambda ()
(if (eq? tstate 0)
(hash-table-delete! alltgls item)
(hash-table-set! alltgls item #t))
|
|
>
<
|
|
|
|
|
>
>
>
>
>
|
>
>
|
|
|
|
|
|
|
|
|
>
>
>
|
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
|
(if val
val
(if (not (null? values))
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
(key-lbs (dboard:tabdat-key-listboxes tabdat))
(db-target-dat (rmt:get-targets))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
(list->vector
(take (append (string-split x "/")
(make-list (length header) "na"))
(length header)))))
(all-targets (append (list (munge-target (string-intersperse
(map (lambda (x) "%") header)
"/")))
db-targets
(map munge-target
runconf-targs)
))
(key-listboxes (if key-lbs key-lbs (make-list (length header) #f))))
(if (not (dboard:tabdat-key-listboxes tabdat))(dboard:tabdat-key-listboxes-set! tabdat key-listboxes))
(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 "x60"
#:fontsize "10"
#:expand "YES" ;; "VERTICAL"
;; #:dropdown "YES"
#:editbox "YES"
#:action (lambda (obj a b c)
(debug:catch-and-dump action-proc "update-target-selector"))
#:caret_cb (lambda (obj a b c)
(debug:catch-and-dump action-proc "update-target-selector"))
))))
;; 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)))
(res (list listboxes
(map (lambda (htxt lb)
(iup:vbox
(iup:label htxt)
lb))
header
listboxes))))
(dboard:tabdat-key-listboxes-set! tabdat res)
res)
(loop (car remkeys)
(cdr remkeys)
(append refvals (list selected-value))
(+ indx 1)
(append lbs (list lb))))))))
;; Make a vertical list of toggles using items, when toggled call proc with the conc'd string
;; interspersed with commas
;;
(define (dashboard:text-list-toggle-box items proc)
(let ((alltgls (make-hash-table)))
(apply iup:vbox
(map (lambda (item)
(iup:toggle
item
#:fontsize 8
#:expand "YES"
#:action (lambda (obj tstate)
(debug:catch-and-dump
(lambda ()
(if (eq? tstate 0)
(hash-table-delete! alltgls item)
(hash-table-set! alltgls item #t))
|
| ︙ | | | ︙ | |
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
|
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-controls commondat tabdat #!key (tab-num #f))
(let* ((targets (make-hash-table))
(test-records (make-hash-table))
(all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '()))
(test-names (hash-table-keys all-tests-registry))
(sorted-testnames #f)
(action "-run")
(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))))
(curr-runname (dboard:tabdat-run-name tabdat)))
(dboard:tabdat-target-set! tabdat targ)
;; (if (dboard:tabdat-updater-for-runs tabdat)
;; ((dboard:tabdat-updater-for-runs tabdat)))
(if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
(equal? (dboard:tabdat-run-name tabdat) ""))
(dboard:tabdat-run-name-set! tabdat curr-runname))
(dashboard:update-run-command tabdat))))
(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))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
<
<
<
|
<
<
<
<
<
<
<
|
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
|
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dboard:target-updater tabdat) ;; key-listboxes)
(let ((targ (map (lambda (x)
(iup:attribute x "VALUE"))
(car (dashboard:update-target-selector tabdat))))
(curr-runname (dboard:tabdat-run-name tabdat)))
(dboard:tabdat-target-set! tabdat targ)
;; (if (dboard:tabdat-updater-for-runs tabdat)
;; ((dboard:tabdat-updater-for-runs tabdat)))
(if (or (not (equal? curr-runname (dboard:tabdat-run-name tabdat)))
(equal? (dboard:tabdat-run-name tabdat) ""))
(dboard:tabdat-run-name-set! tabdat curr-runname))
(dashboard:update-run-command tabdat)))
(define (dashboard:run-controls commondat tabdat #!key (tab-num #f))
(let* ((targets (make-hash-table))
(test-records (make-hash-table))
(all-tests-registry (tests:get-all)) ;; (tests:get-valid-tests *toppath* '()))
(test-names (hash-table-keys all-tests-registry))
(sorted-testnames #f)
(action "-run")
(cmdln "")
(runlogs (make-hash-table))
;;; (key-listboxes #f)
(update-keyvals (lambda () ;; gets called in dashboard:update-target-selector as "action-proc"
(dboard:target-updater (dboard:tabdat-key-listboxes tabdat))))
(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))
|
| ︙ | | | ︙ | |
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
|
;; Target, testpatt, state and status input boxes
;;
(iup:vbox
;; Command to run, placed over the top of the canvas
(dcommon:command-action-selector commondat tabdat tab-num: tab-num)
(dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
(dcommon:command-testname-selector commondat tabdat update-keyvals key-listboxes))
(dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))
;;(iup:frame
;; #:title "Logs" ;; To be replaced with tabs
;; (let ((logs-tb (iup:textbox #:expand "YES"
;; #:multiline "YES")))
;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
;; logs-tb))
)))
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-times commondat tabdat #!key (tab-num #f))
(let ((drawing (vg:drawing-new))
(run-times-tab-updater (lambda ()
(debug:catch-and-dump
(lambda ()
(let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
(if tabdat
(let ((last-data-update (dboard:tabdat-last-data-update tabdat))
(now-time (current-seconds)))
(dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
(if (> (- now-time last-data-update) 5)
(if (not (dboard:tabdat-running-layout tabdat))
(begin
(dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
(dboard:tabdat-last-data-update-set! tabdat now-time)
(thread-start! (make-thread
(lambda ()
(dboard:tabdat-running-layout-set! tabdat #t)
(dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
(dboard:tabdat-running-layout-set! tabdat #f))
"run-times-tab-layout-updater")))
))))))
"dashboard:run-times-tab-updater"))))
(dboard:tabdat-drawing-set! tabdat drawing)
(dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
#:value 200
(let* ((tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#: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))))
(print "run-path: " run-path)
(if (number? run-id)
(begin
(dboard:tabdat-curr-run-id-set! tabdat run-id)
(dboard:tabdat-view-changed-set! tabdat #t))
(debug:print-error 0 *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)
tb)
(iup:vbox
(let* ((cnv-obj (iup:canvas
;; #:size "500x400"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
|
;; Target, testpatt, state and status input boxes
;;
(iup:vbox
;; Command to run, placed over the top of the canvas
(dcommon:command-action-selector commondat tabdat tab-num: tab-num)
(dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
(dcommon:command-testname-selector commondat tabdat update-keyvals)) ;; key-listboxes))
(dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))
;;(iup:frame
;; #:title "Logs" ;; To be replaced with tabs
;; (let ((logs-tb (iup:textbox #:expand "YES"
;; #:multiline "YES")))
;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
;; logs-tb))
)))
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-times commondat tabdat #!key (tab-num #f))
(let* ((drawing (vg:drawing-new))
(run-times-tab-updater (lambda ()
(debug:catch-and-dump
(lambda ()
(let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
(if tabdat
(let ((last-data-update (dboard:tabdat-last-data-update tabdat))
(now-time (current-seconds)))
(dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
(if (> (- now-time last-data-update) 5)
(if (not (dboard:tabdat-running-layout tabdat))
(begin
(dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
(dboard:tabdat-last-data-update-set! tabdat now-time)
(thread-start! (make-thread
(lambda ()
(dboard:tabdat-running-layout-set! tabdat #t)
(dashboard:run-times-tab-layout-updater commondat tabdat tab-num)
(dboard:tabdat-running-layout-set! tabdat #f))
"run-times-tab-layout-updater")))
))))))
"dashboard:run-times-tab-updater")))
(key-listboxes #f) ;;
(update-keyvals (lambda ()
(dboard:target-updater tabdat))))
(dboard:tabdat-drawing-set! tabdat drawing)
(dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
#:value 150
(iup:vbox
(let* ((tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#: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-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path)
(if (number? run-id)
(begin
(dboard:tabdat-curr-run-id-set! tabdat run-id)
(dboard:tabdat-view-changed-set! tabdat #t))
(debug:print-error 0 *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)
tb)
(dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
(dcommon:command-testname-selector commondat tabdat update-keyvals))
(iup:vbox
(let* ((cnv-obj (iup:canvas
;; #:size "500x400"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
|
| ︙ | | | ︙ | |
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
|
(tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
userdata: (conc "run-id: " run-id))
(hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
run-ids))
(print "Updating rundat")
(update-rundat tabdat
"%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
100 ;; (dboard:tabdat-numruns tabdat)
"%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
(let ((res '()))
(for-each (lambda (key)
(if (not (equal? key "runname"))
(let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
(if val (set! res (cons (list key val) res))))))
(dboard:tabdat-dbkeys tabdat))
res))))
;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
(let ((cnv (dboard:tabdat-cnv tabdat))
(dwg (dboard:tabdat-drawing tabdat))
(mtx (dboard:tabdat-runs-mutex tabdat))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
|
|
|
>
>
>
>
|
|
|
|
|
|
>
|
|
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
|
(tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
userdata: (conc "run-id: " run-id))
(hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
run-ids))
(print "Updating rundat")
(if (dboard:tabdat-keys tabdat) ;; have keys yet?
(let* ((num-keys (length (dboard:tabdat-keys tabdat)))
(targpatt (map (lambda (k v)
(list k v))
(dboard:tabdat-keys tabdat)
(take (append (or (dboard:tabdat-target tabdat);; (string-split (dboard: "/")
'("%" "%"))
(make-list num-keys "%"))
num-keys)
))
(runpatt (if (dboard:tabdat-target tabdat)
(last (dboard:tabdat-target tabdat))
"%")))
(print "targpatt: " targpatt " runpatt: " runpatt)
(if (dboard:tabdat-view-changed tabdat)
(let ((dwg (dboard:tabdat-drawing tabdat)))
(dboard:tabdat-layout-update-ok-set! tabdat #f)
(vg:drawing-libs-set! dwg (make-hash-table))
(vg:drawing-insts-set! dwg (make-hash-table))
(vg:drawing-cache-set! dwg '())
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
(dboard:tabdat-max-row-set! tabdat 0)))
(update-rundat tabdat
runpatt
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
100 ;; (dboard:tabdat-numruns tabdat)
"%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
targpatt
;; old method
;; (let ((res '()))
;; (for-each (lambda (key)
;; (if (not (equal? key "runname"))
;; (let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
;; (if val (set! res (cons (list key val) res))))))
;; (dboard:tabdat-dbkeys tabdat))
;; res)
)))))
;; run times canvas updater
;;
(define (dashboard:run-times-tab-canvas-updater commondat tabdat tab-num)
(let ((cnv (dboard:tabdat-cnv tabdat))
(dwg (dboard:tabdat-drawing tabdat))
(mtx (dboard:tabdat-runs-mutex tabdat))
|
| ︙ | | | ︙ | |
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
|
(mtx (dboard:tabdat-runs-mutex tabdat))
(drawing (dboard:tabdat-drawing tabdat))
(runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
(layout-start (current-milliseconds))
(allruns (dboard:tabdat-allruns tabdat))
(num-runs (length allruns))
(cnv (dboard:tabdat-cnv tabdat)))
(if (canvas? cnv)
(let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
((originx originy) (canvas-origin cnv))
((calc-y) (lambda (rownum)
(- (/ sizey 2)
(* rownum row-height))))
((fixed-originx) (if (dboard:tabdat-originx tabdat)
|
>
|
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
|
(mtx (dboard:tabdat-runs-mutex tabdat))
(drawing (dboard:tabdat-drawing tabdat))
(runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
(layout-start (current-milliseconds))
(allruns (dboard:tabdat-allruns tabdat))
(num-runs (length allruns))
(cnv (dboard:tabdat-cnv tabdat)))
(dboard:tabdat-layout-update-ok-set! tabdat #t)
(if (canvas? cnv)
(let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
((originx originy) (canvas-origin cnv))
((calc-y) (lambda (rownum)
(- (/ sizey 2)
(* rownum row-height))))
((fixed-originx) (if (dboard:tabdat-originx tabdat)
|
| ︙ | | | ︙ | |
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
|
(list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
(if x x "")))))
(run-key (string-intersperse key-vals "\n"))
(run-full-name (string-intersperse key-vals "/"))
(curr-run-start-row (dboard:tabdat-max-row tabdat)))
;; (print "run: " run-full-name " curr-run-start-row: " curr-run-start-row)
(if (not (vg:lib-get-component runslib run-full-name))
(let* ((hierdat (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat))) ;; hierarchial list of ids
(tests-ht (dboard:rundat-tests rundat))
(all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat
(testsdat (hash-table-values tests-ht))
(runcomp (vg:comp-new));; new component for this run
(rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...)
;; (row-height 4)
(run-start (dboard:min-max < (map db:test-get-event_time testsdat)))
|
>
>
|
>
>
>
|
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
|
(list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
(if x x "")))))
(run-key (string-intersperse key-vals "\n"))
(run-full-name (string-intersperse key-vals "/"))
(curr-run-start-row (dboard:tabdat-max-row tabdat)))
;; (print "run: " run-full-name " curr-run-start-row: " curr-run-start-row)
(if (not (vg:lib-get-component runslib run-full-name))
(let* ((hierdat (if (or (dboard:rundat-data-changed rundat) ;; attempt to not sort when possible.
(not (dboard:rundat-hierdat rundat)))
(let ((hd (dboard:tests-sort-by-time-group-by-item (dboard:rundat-tests rundat)))) ;; hierarchial list of ids
(dboard:rundat-hierdat-set! rundat hd)
hd)
(dboard:run-hierdat rundat)))
(tests-ht (dboard:rundat-tests rundat))
(all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat
(testsdat (hash-table-values tests-ht))
(runcomp (vg:comp-new));; new component for this run
(rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...)
;; (row-height 4)
(run-start (dboard:min-max < (map db:test-get-event_time testsdat)))
|
| ︙ | | | ︙ | |
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
|
;; This is the box around the tests of an iterated test
(vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
line-color: (vg:rgb->number 0 0 255 a: 128)
font: "Helvetica -10"))
;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
(dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw
(testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs)))))
;; If it is an iterated test put box around it now.
(if (not (null? tests-tal))
(if #f ;; (> (- (current-seconds) update-start-time) 5)
(print "drawing runs taking too long")
(testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1))))))
;; placeholder box
(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
;; instantiate the component
(let* ((extents (vg:components-get-extents drawing runcomp))
(new-xtnts (apply vg:grow-rect 5 5 extents))
|
>
|
>
|
|
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
|
;; This is the box around the tests of an iterated test
(vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
text: (db:test-get-testname (hash-table-ref tests-ht (car test-ids)))
line-color: (vg:rgb->number 0 0 255 a: 128)
font: "Helvetica -10"))
;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
(dboard:tabdat-view-changed-set! tabdat #t))) ;; trigger a redraw
(if (dboard:tabdat-layout-update-ok tabdat)
(testitemloop (car tidstal)(cdr tidstal)(+ item-num 1) new-test-objs))))))
;; If it is an iterated test put box around it now.
(if (not (null? tests-tal))
(if #f ;; (> (- (current-seconds) update-start-time) 5)
(print "drawing runs taking too long")
(if (dboard:tabdat-layout-update-ok tabdat)
(testsloop (car tests-tal)(cdr tests-tal)(+ test-num 1)))))))
;; placeholder box
(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 1))
;; (let ((y (calc-y (dboard:tabdat-max-row tabdat)))) ;; (- sizey (* (dboard:tabdat-max-row tabdat) row-height))))
;; (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
;; instantiate the component
(let* ((extents (vg:components-get-extents drawing runcomp))
(new-xtnts (apply vg:grow-rect 5 5 extents))
|
| ︙ | | | ︙ | |
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
|
(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 2))
;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
))
;; end of the run handling loop
(let ((newdoneruns (cons rundat doneruns)))
(if (null? runtal)
(begin
(dboard:tabdat-not-done-runs-set! tabdat '())
(dboard:tabdat-done-runs-set! tabdat allruns))
(if #f ;; (> (- (current-seconds) update-start-time) 5)
(begin
(print "drawing runs taking too long.... have " (length runtal) " remaining")
;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
(dboard:tabdat-not-done-runs-set! tabdat runtal))
(begin
(runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns)))))))) ;; new-run-start-row
)
(print "Layout end: " (current-milliseconds) " delta: " (- (current-milliseconds) layout-start))))
(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))
(define (dashboard:runs-tab-updater commondat tab-num)
(debug:catch-and-dump
(lambda ()
|
>
>
|
|
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
|
(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat) 2))
;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
))
;; end of the run handling loop
(let ((newdoneruns (cons rundat doneruns)))
(if (null? runtal)
(begin
(dboard:rundat-data-changed-set! rundat #f)
(dboard:tabdat-not-done-runs-set! tabdat '())
(dboard:tabdat-done-runs-set! tabdat allruns))
(if #f ;; (> (- (current-seconds) update-start-time) 5)
(begin
(print "drawing runs taking too long.... have " (length runtal) " remaining")
;; (dboard:tabdat-done-runs-set! tabdat newdoneruns) ;; taking too long? stop here!
;; (time (vg:draw (dboard:tabdat-drawing tabdat) #t))
(dboard:tabdat-not-done-runs-set! tabdat runtal))
(begin
(if (dboard:tabdat-layout-update-ok tabdat)
(runloop (car runtal)(cdr runtal) (+ run-num 1) newdoneruns))))))))) ;; new-run-start-row
)
(print "Layout end: " (current-milliseconds) " delta: " (- (current-milliseconds) layout-start))))
(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater")))
(define (dashboard:runs-tab-updater commondat tab-num)
(debug:catch-and-dump
(lambda ()
|
| ︙ | | | ︙ | |