Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1562,13 +1562,10 @@ ;; R U N ;;====================================================================== ;; ;; display and manage a single run at a time -;; (define dashboard:update-run-summary-tab #f) -;; (define dashboard:update-new-view-tab #f) - ;; This is the Run Summary tab ;; (define (dashboard:one-run commondat tabdat #!key (tab-num #f)) (let* ((tb (iup:treebox #:value 0 @@ -1575,21 +1572,24 @@ #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) - ;; (print "obj: " obj ", id: " id ", state: " state) - (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id tabdat (cdr run-path)))) - (if (number? run-id) - (begin - (dboard:tabdat-curr-run-id-set! tabdat run-id) - (dboard:tabdat-layout-update-ok-set! tabdat #f) - ;; (dashboard:update-run-summary-tab) - ) - ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) - )) + (debug:catch-and-dump + (lambda () + ;; (print "obj: " obj ", id: " id ", state: " state) + (let* ((run-path (tree:node->path obj id)) + (run-id (tree-path->run-id tabdat (cdr run-path)))) + (if (number? run-id) + (begin + (dboard:tabdat-curr-run-id-set! tabdat run-id) + (dboard:tabdat-layout-update-ok-set! tabdat #f) + ;; (dashboard:update-run-summary-tab) + ) + ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) + ))) + "selection-cb in one-run") ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" @@ -1603,199 +1603,15 @@ (one-run-updater (lambda () (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 - tb - run-matrix))) -;; (iup:vbox -;; (let* ((cnv-obj (iup:canvas -;; ;; #:size "500x400" -;; #:expand "YES" -;; #:scrollbar "YES" -;; #:posx "0.5" -;; #:posy "0.5" -;; #:action (make-canvas-action -;; (lambda (c xadj yadj) -;; (debug:catch-and-dump -;; (lambda () -;; (if (not (dboard:tabdat-cnv tabdat)) -;; (dboard:tabdat-cnv-set! tabdat c)) -;; (let ((drawing (dboard:tabdat-drawing tabdat)) -;; (old-xadj (dboard:tabdat-xadj tabdat)) -;; (old-yadj (dboard:tabdat-yadj tabdat))) -;; (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) -;; (begin -;; (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) -;; (dboard:tabdat-view-changed-set! tabdat #t) -;; (dboard:tabdat-xadj-set! tabdat (* -500 (- xadj 0.5))) -;; (dboard:tabdat-yadj-set! tabdat (* 500 (- yadj 0.5))) -;; )))) -;; "iup:canvas action dashboard:one-run"))) -;; #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think. -;; (debug:catch-and-dump -;; (lambda () -;; (let* ((drawing (dboard:tabdat-drawing tabdat)) -;; (scalex (vg:drawing-scalex drawing))) -;; (dboard:tabdat-view-changed-set! tabdat #t) -;; (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex) -;; (vg:drawing-scalex-set! drawing -;; (+ scalex -;; (if (> step 0) -;; (* scalex 0.02) -;; (* scalex -0.02)))))) -;; "dashboard:one-run wheel-cb")) -;; ))) -;; cnv-obj)))) - - -;; This is the New View tab -;; -;; (define (dashboard:new-view db commondat tabdat #!key (tab-num #f)) -;; (let* ((tb (iup:treebox -;; #:value 0 -;; #:name "Runs" -;; #:expand "YES" -;; #:addexpanded "NO" -;; #:selection-cb -;; (lambda (obj id state) -;; ;; (print "obj: " obj ", id: " id ", state: " state) -;; (let* ((run-path (tree:node->path obj id)) -;; (run-id (tree-path->run-id tabdat (cdr run-path)))) -;; (if (number? run-id) -;; (begin -;; (dboard:tabdat-curr-run-id-set! tabdat run-id) -;; ;; (dashboard:update-new-view-tab) -;; (dboard:tabdat-layout-update-ok-set! tabdat #f) -;; ) -;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))) -;; ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) -;; ))) -;; (cell-lookup (make-hash-table)) -;; (run-matrix (iup:matrix -;; #:expand "YES" -;; #:click-cb -;; (lambda (obj lin col status) -;; (let* ((toolpath (car (argv))) -;; (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))))) -;; (new-view-updater (lambda () -;; (if (dashboard:database-changed? commondat tabdat) -;; (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) -;; (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records -;; (run-id (dboard:tabdat-curr-run-id tabdat)) -;; (last-update 0) ;; fix me -;; (tests-dat (dboard:get-tests-dat tabdat run-id last-update)) -;; (tests-mindat (dcommon:minimize-test-data tests-dat)) -;; (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) -;; (row-indices (cadr indices)) -;; (col-indices (car indices)) -;; (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) -;; (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) -;; (max-visible (max (- (dboard:tabdat-num-tests tabdat) 15) 3)) ;; (dboard:tabdat-num-tests tabdat) is proportional to the size of the window -;; (numrows 1) -;; (numcols 1) -;; (changed #f) -;; (runs-hash (let ((ht (make-hash-table))) -;; (for-each (lambda (run) -;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) -;; (vector-ref runs-dat 1)) -;; ht)) -;; (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)))))) -;; ;; (iup:attribute-set! tb "VALUE" "0") -;; ;; (iup:attribute-set! tb "NAME" "Runs") -;; ;; Update the runs tree -;; (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")) -;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) -;; (run-path (append key-vals (list run-name))) -;; (existing (tree:find-node tb run-path))) -;; (if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f)) -;; (begin -;; (hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path) -;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat) -;; ;; (conc rownum ":" colnum) col-name) -;; ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) -;; ;; Here we update the tests treebox and tree keys -;; (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) -;; (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 -;; ;; (iup:attribute-set! run-matrix "NUMCOL_VISIBLE" max-col) -;; ;; (iup:attribute-set! run-matrix "NUMLIN_VISIBLE" (if (> max-row max-visible) max-visible max-row)) -;; -;; ;; 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"))))))) -;; (dboard:commondat-add-updater commondat new-view-updater tab-num: tab-num) -;; (dboard:tabdat-runs-tree-set! tabdat tb) -;; (iup:split -;; tb -;; run-matrix))) + (iup:vbox + (iup:split + tb + run-matrix) + (dboard:make-controls commondat tabdat)))) ;;====================================================================== ;; R U N S ;;====================================================================== @@ -1838,12 +1654,11 @@ (hash-table-delete! *collapsed* tname)) (hash-table-keys *collapsed*)) (iup:attribute-set! obj "TITLE" "Collapse")))) (mark-for-update tabdat)) "make-controls collapse button")) - #:expand "NO" #:size "40x15")) - ) + #:expand "NO" #:size "40x15"))) (iup:vbox ;; (iup:button "Sort -t" #:action (lambda (obj) ;; (next-sort-option) ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) ;; (mark-for-update tabdat))) @@ -2037,21 +1852,21 @@ (nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) - (controls '()) + (controls (dboard:make-controls commondat runs-dat)) ;; '()) (lftlst '()) (hdrlst '()) (bdylst '()) (result '()) (i 0) (btn-height (dboard:tabdat-runs-btn-height runs-dat)) (btn-fontsz (dboard:tabdat-runs-btn-fontsz runs-dat)) (cell-width (dboard:tabdat-runs-cell-width runs-dat))) ;; controls (along bottom) - (set! controls (dboard:make-controls commondat runs-dat)) + ;; (set! controls (dboard:make-controls commondat runs-dat)) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox (iup:label) ;; (iup:valuator) (apply iup:vbox @@ -3000,14 +2815,14 @@ 1)))) (let ((th1 (make-thread (lambda () (thread-sleep! 1) (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab - (dboard:commondat-please-update-set! commondat #t) + ;; (dboard:commondat-please-update-set! commondat #t) ;; MRW: ww36.3 - why was please update set true here? Removing it for now. ;; (dashboard:run-update commondat) ) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) (thread-start! th1) (thread-start! th2) (thread-join! th2)))) (main)