Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -142,14 +142,12 @@ tnum '()))) (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) (for-each (lambda (updater) - (debug:print 3 *default-log-port* "Running " updater) - (updater) - ) - + ;; (debug:print 3 *default-log-port* "Running " updater) + (updater)) updaters)))) ;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num ;; (define (dboard:commondat-add-updater commondat updater #!key (tab-num #f)) @@ -1305,11 +1303,11 @@ (if (dboard:tabdat-filters-changed tabdat) 0 last-update) *dashboard-mode*) '()))) ;; get 'em all - (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) + ;; (debug:print 0 *default-log-port* "dboard:get-tests-dat: got " (length tdat) " test records for run " run-id) (sort tdat (lambda (a b) (let* ((aval (vector-ref a 2)) (bval (vector-ref b 2)) (anum (string->number aval)) (bnum (string->number bval))) @@ -1316,24 +1314,21 @@ (if (and anum bnum) (< anum bnum) (string<= aval bval))))))) -(define (dashboard:safe-cadr-assoc name lst) - (let ((res (assoc name lst))) - (if (and res (> (length res) 1)) - (cadr res) - #f))) (define (dboard:update-tree tabdat runs-hash runs-header tb) - (let ((run-ids (sort (filter number? (hash-table-keys runs-hash)) - (lambda (a b) - (let* ((record-a (hash-table-ref runs-hash a)) - (record-b (hash-table-ref runs-hash b)) - (time-a (db:get-value-by-header record-a runs-header "event_time")) - (time-b (db:get-value-by-header record-b runs-header "event_time"))) - (< time-a time-b)))))) + (let* ((run-ids (sort (filter number? (hash-table-keys runs-hash)) + (lambda (a b) + (let* ((record-a (hash-table-ref runs-hash a)) + (record-b (hash-table-ref runs-hash b)) + (time-a (db:get-value-by-header record-a runs-header "event_time")) + (time-b (db:get-value-by-header record-b runs-header "event_time"))) + (< time-a time-b))))) + (changed #f) + (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))) (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) (dboard:tabdat-keys tabdat))) (run-name (db:get-value-by-header run-record runs-header "runname")) @@ -1374,87 +1369,68 @@ (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) ht))) (dboard:tabdat-filters-changed-set! tabdat #f) - (let loop ((pass-num 0) - (changed #f)) - ;; Update the runs tree + ;; let loop ((pass-num 0) + ;; (changed #f)) + ;; ;; Update the runs tree (dboard:update-tree tabdat runs-hash runs-header tb) - (if (eq? pass-num 1) - (begin ;; big reset - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") - (iup:attribute-set! run-matrix "NUMCOL" max-col ) - (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)))) ;; min of 20 - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (and (eq? pass-num 0) changed)) - (set! changed (dcommon:modify-if-different run-matrix key name changed))))) - row-indices) - - (print "row-indices: " row-indices " col-indices: " col-indices) - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass - - ;; Cell contents - (for-each (lambda (entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (test-name row-name) ;; (list-ref valuedat 1)) - (item-path col-name) ;; (list-ref valuedat 2)) - (state (list-ref valuedat 1)) - (status (list-ref valuedat 2)) - (value (let ((res (gutils:get-color-for-state-status state status))) - (if (and (list? res) - (> (length res) 1)) - res - #f)))) ;; (list "n/a" "256 256 256")))) - (print "value: " value " row-name: " (cadr value) " row-color: " (car value)) - (print "(assoc row-name row-indices): " (assoc row-name row-indices) " (assoc col-name col-indices): " (assoc col-name col-indices)) - (if value - (let* ((row-name (cadr value)) - (row-color (car value)) - (row-num (dashboard:safe-cadr-assoc row-name row-indices)) ;; (cadr (assoc row-name row-indices))) - (col-num (dashboard:safe-cadr-assoc col-name col-indices)) - (key (conc row-num ":" col-num))) - (if (and row-num col-num) - (begin - (hash-table-set! cell-lookup key test-id) - (set! changed (dcommon:modify-if-different run-matrix key row-name changed)) - (set! changed (dcommon:modify-if-different run-matrix (conc "BGCOLOR" key) row-color changed))) - (print "ERROR: row-num=" row-num " col-num=" col-num)))) - )) - tests-mindat) - - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass due to contents changing - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (print "ind: " ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (set! changed (dcommon:modify-if-different run-matrix key name changed)) - (if changed (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num))))) - col-indices) - - (if (and (eq? pass-num 0) changed) - (loop 1 #t)) ;; force second pass due to column labels changing - - ;; (debug:print 0 *default-debug-port* "one-run-updater, changed: " changed " pass-num: " pass-num) - (print "one-run-updater, changed: " changed " pass-num: " pass-num) - (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))) + + + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! run-matrix "NUMCOL" max-col ) + (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)) ;; min of 20 + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + + ;; Cell contents + (for-each (lambda (entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + tests-mindat) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) + col-indices) + (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; @@ -1531,11 +1507,10 @@ (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id "&"))) (system cmd))))) (one-run-updater (lambda () - (print "Got here!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!") (if (dashboard:database-changed? commondat tabdat) (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix))))) (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) (dboard:tabdat-runs-tree-set! tabdat tb) (iup:split @@ -2224,10 +2199,12 @@ ;; point inside line ;; (define-inline (dashboard:px-between px lx1 lx2) (and (< lx1 px)(> lx2 px))) +(define (dashboard:summary-tab-updater commondat tab-num) + (if dashboard:update-summary-tab (dashboard:update-summary-tab))) ;; can a bar be placed in row "rownum" covering x1 to x2 without overlapping with existing ;; bars? Use num-rows to check that a block will fit from rownum to (+ rownum num-rows) ;; (define (dashboard:row-collision rowhash rownum x1 x2 #!key (num-rows #f)) (let ((lastrow (if num-rows (+ rownum num-rows) rownum))) @@ -2836,11 +2813,11 @@ (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)))))) dbkeys) res)))) - (debug:print 0 *default-log-port* "fres: " fres) + ;; (debug:print 0 *default-log-port* "fres: " fres) fres))) (let ((uidat (dboard:commondat-uidat commondat))) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) @@ -2896,11 +2873,10 @@ ;; (lambda () ;; (dashboard:summary-tab-updater commondat 0)) ;; tab-num: 0) ;; runs tab (dboard:commondat-curr-tab-num-set! commondat 0) - ;; this next call is working and doing what it should (dboard:commondat-add-updater commondat (lambda () (dashboard:runs-tab-updater commondat 1)) tab-num: 1) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -67,15 +67,15 @@ (hash-table-set! *cachedata* "runid-to-col" (make-hash-table)) (hash-table-set! *cachedata* "testname-to-row" (make-hash-table)) ;; modify a cell if the data is changed, return #t or-ed with previous if modified, #f elsewise ;; -(define (dcommon:modify-if-different mtrx cell-name new-val prev-changed) +(define (dcommon:modifiy-if-different mtrx cell-name new-val prev-changed) (let ((curr-val (iup:attribute mtrx cell-name))) (if (not (equal? curr-val new-val)) (begin - (iup:attribute-set! mtrx cell-name new-val) + (iup:attribute-set! mtrx cell-name col-name) #t) ;; need a re-draw prev-changed))) ;; TO-DO @@ -144,11 +144,11 @@ (run-name (db:get-value-by-header run-record header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name)))) (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path) ;; modify cell - but only if changed - (set! changed (dcommon:modify-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed)) + (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed)) (hash-table-set! runid-to-col run-id (list colnum run-record)) ;; Here we update the tests treebox and tree keys (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) (set! colnum (+ colnum 1)))) @@ -203,11 +203,11 @@ userdata: (conc "test-id: " test-id)) (let ((node-num (tree:find-node tb (cons "Runs" test-path))) (color (car (gutils:get-color-for-state-status state status)))) (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color) - (set! changed (dcommon:modify-if-different + (set! changed (dcommon:modifiy-if-different tb (conc "COLOR" node-num) color changed)) ;; (iup:attribute-set! tb (conc "COLOR" node-num) color) @@ -218,21 +218,21 @@ (set! rownum (if (null? rownums) 1 (+ 1 (apply max rownums)))) (hash-table-set! testname-to-row fullname rownum) ;; create the label - (set! changed (dcommon:modify-if-different + (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) (conc rownum ":" 0) dispname changed)) ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) ;; (conc rownum ":" 0) dispname) )) ;; set the cell text and color ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status) - (set! changed (dcommon:modify-if-different + (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) (conc rownum ":" colnum) (if (member state '("ARCHIVED" "COMPLETED")) status state) @@ -240,11 +240,11 @@ ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data) ;; (conc rownum ":" colnum) ;; (if (member state '("ARCHIVED" "COMPLETED")) ;; status ;; state)) - (set! changed (dcommon:modify-if-different + (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) (conc "BGCOLOR" rownum ":" colnum) (car (gutils:get-color-for-state-status state status)) changed)) ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)