Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -246,11 +246,11 @@ ((view-changed #t) : boolean) ((xadj 0) : number) ;; x slider number (if using canvas) ((yadj 0) : number) ;; y slider number (if using canvas) ;; runs-summary tab state - ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs")) ) : list) + ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) ((runs-summary-mode-buttons '()) : list) ((runs-summary-mode 'one-run) : symbol) ((runs-summary-mode-change-callbacks '()) : list) (runs-summary-source-runname-label #f) (runs-summary-dest-runname-label #f) @@ -1473,17 +1473,18 @@ res) (hash-table-ref (dboard:tabdat-last-test-dat tabdat) run-id))) (tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display tests-mindat)) -(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash) +(define (dashboard:runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f)) (let* ((src-run-id (dboard:tabdat-prev-run-id tabdat)) (dest-run-id (dboard:tabdat-curr-run-id tabdat))) (if (and src-run-id dest-run-id) (dcommon:xor-tests-mindat (dashboard:run-id->tests-mindat src-run-id tabdat runs-hash) - (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)) + (dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash) + hide-clean: hide-clean) #f))) (define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) (dboard:runs-summary-control-panel-updater tabdat) (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) @@ -1500,10 +1501,11 @@ (if run-id (let* ((matrix-content (case (dboard:tabdat-runs-summary-mode tabdat) ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash)) ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash)) + ((xor-two-runs-hide-clean) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash hide-clean: #t)) (else (dashboard:run-id->tests-mindat run-id tabdat runs-hash))))) (when matrix-content (let* ((indices (common:sparse-list-generate-index matrix-content)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) @@ -1714,11 +1716,11 @@ (let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat)) (dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat)) (mode (dboard:tabdat-runs-summary-mode tabdat))) (when (and source-runname-label dest-runname-label) (case mode - ((xor-two-runs) + ((xor-two-runs xor-two-runs-hide-clean) (let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat)) (prev-run-id (dboard:tabdat-prev-run-id tabdat)) (curr-runname (if curr-run-id (rmt:get-run-name-from-id curr-run-id) "None")) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -309,11 +309,11 @@ ((not mem2) 1) ((= (length mem1) (length mem2)) 0) ((> (length mem1) (length mem2)) 1) (else -1)))) -(define (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat) +(define (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f)) (let* ((src-hash (dcommon:tests-mindat->hash src-tests-mindat)) (dest-hash (dcommon:tests-mindat->hash dest-tests-mindat)) (all-keys (reverse (sort (delete-duplicates @@ -325,79 +325,91 @@ ((> 0 (string-compare3 (car a) (car b))) #f) ((< 0 (string-compare3 (cdr a) (cdr b))) #t) (else #f))) )))) - (map ;; TODO: rename xor to delta globally in dcommon and dashboard - (lambda (key) - (let* ((test-name (car key)) - (item-path (cdr key)) - - (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status) - (dest-test-id (if dest-value (list-ref dest-value 0) #f)) - (dest-state (if dest-value (list-ref dest-value 1) #f)) - (dest-status (if dest-value (list-ref dest-value 2) #f)) - - (src-value (hash-table-ref/default src-hash key #f)) ;; (list test-id state status) - (src-test-id (if src-value (list-ref src-value 0) #f)) - (src-state (if src-value (list-ref src-value 1) #f)) - (src-status (if src-value (list-ref src-value 2) #f)) - - (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete - - (dest-complete - (and dest-value dest-state dest-status - (equal? dest-state "COMPLETED") - (not (member dest-status incomplete-statuses)))) - (src-complete - (and src-value src-state src-status - (equal? src-state "COMPLETED") - (not (member src-status incomplete-statuses)))) - (status-compare-result (dcommon:status-compare3 src-status dest-status)) - (xor-new-item - (cond - ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a ) - ;; neither complete -> bad - - ;; src !complete, dest complete -> better - ((and (not dest-complete) (not src-complete)) - (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE")) - ((not dest-complete) - (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE")) - ((not src-complete) - (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE")) - ((and - (equal? src-state dest-state) - (equal? src-status dest-status)) - (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) )) - ;; better or worse: pass > warn > waived > skip > fail > abort - ;; pass > warn > waived > skip > fail > abort - - ((= 1 status-compare-result) ;; src is better, dest is worse - (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status))) - (else - (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status))) - ))) - (list test-name item-path xor-new-item))) - all-keys))) + (let ((res + (map ;; TODO: rename xor to delta globally in dcommon and dashboard + (lambda (key) + (let* ((test-name (car key)) + (item-path (cdr key)) + + (dest-value (hash-table-ref/default dest-hash key #f)) ;; (list test-id state status) + (dest-test-id (if dest-value (list-ref dest-value 0) #f)) + (dest-state (if dest-value (list-ref dest-value 1) #f)) + (dest-status (if dest-value (list-ref dest-value 2) #f)) + + (src-value (hash-table-ref/default src-hash key #f)) ;; (list test-id state status) + (src-test-id (if src-value (list-ref src-value 0) #f)) + (src-state (if src-value (list-ref src-value 1) #f)) + (src-status (if src-value (list-ref src-value 2) #f)) + + (incomplete-statuses '("DELETED" "INCOMPLETE" "STUCK/DEAD" "N/A")) ;; if any of these statuses apply, treat test as incomplete + + (dest-complete + (and dest-value dest-state dest-status + (equal? dest-state "COMPLETED") + (not (member dest-status incomplete-statuses)))) + (src-complete + (and src-value src-state src-status + (equal? src-state "COMPLETED") + (not (member src-status incomplete-statuses)))) + (status-compare-result (dcommon:status-compare3 src-status dest-status)) + (xor-new-item + (cond + ;; complete, for this case means: state=compelte AND status not in ( deleted uncomplete stuck/dead n/a ) + ;; neither complete -> bad + + ;; src !complete, dest complete -> better + ((and (not dest-complete) (not src-complete)) + (list dest-test-id "BOTH-BAD" "BOTH-INCOMPLETE")) + ((not dest-complete) + (list src-test-id "DIFF-MISSING" "DEST-INCOMPLETE")) + ((not src-complete) + (list dest-test-id "DIFF-NEW" "SRC-INCOMPLETE")) + ((and + (equal? src-state dest-state) + (equal? src-status dest-status)) + (list dest-test-id (conc "CLEAN") (conc "CLEAN-" dest-status) )) + ;; better or worse: pass > warn > waived > skip > fail > abort + ;; pass > warn > waived > skip > fail > abort + + ((= 1 status-compare-result) ;; src is better, dest is worse + (list dest-test-id "DIRTY-WORSE" (conc src-status "->" dest-status))) + (else + (list dest-test-id "DIRTY-BETTER" (conc src-status "->" dest-status))) + ))) + (list test-name item-path xor-new-item))) + all-keys))) + ;;(BB> "hide-clean="hide-clean) + (if hide-clean + (filter + (lambda (item) + ;;(print item) + (not + (equal? + "CLEAN" + (list-ref (list-ref item 2) 1)))) + res) + res)))) (define (dcommon:examine-xterm run-id test-id) (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) (if (not testdat) - (begin - (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") - (exit 1)) + (begin + (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") + (exit 1)) (let* ((rundir (if testdat - (db:test-get-rundir testdat) - logfile)) + (db:test-get-rundir testdat) + logfile)) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (xterm (lambda () (if (directory-exists? rundir) (let* ((shell (if (get-environment-variable "SHELL") - (conc "-e " (get-environment-variable "SHELL")) - "")) + (conc "-e " (get-environment-variable "SHELL")) + "")) (command (conc "cd " rundir ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (print "Command =" command) (common:without-vars command @@ -411,21 +423,21 @@ ;;====================================================================== ;; Table of keys (define (dcommon:keys-matrix rawconfig) (let* ((curr-row-num 1) - (key-vals (configf:section-vars rawconfig "fields")) - (keys-matrix (iup:matrix - #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" - ;; #:scrollbar "YES" - #:numcol 1 - #:numlin (length key-vals) - #:numcol-visible 1 - #:numlin-visible (length key-vals) - #:click-cb (lambda (obj lin col status) - (print "obj: " obj " lin: " lin " col: " col " status: " status))))) + (key-vals (configf:section-vars rawconfig "fields")) + (keys-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" ;; "VERTICAL" + ;; #:scrollbar "YES" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (length key-vals) + #:click-cb (lambda (obj lin col status) + (print "obj: " obj " lin: " lin " col: " col " status: " status))))) ;; (iup:attribute-set! keys-matrix "0:0" "Run Keys") (iup:attribute-set! keys-matrix "WIDTH0" 0) (iup:attribute-set! keys-matrix "0:1" "Key Name") ;; (iup:attribute-set! keys-matrix "WIDTH1" "100") ;; fill in keys @@ -440,18 +452,18 @@ keys-matrix)) ;; Section to table (define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f)) (let* ((curr-row-num 1) - (key-vals (configf:section-vars rawconfig sectionname)) - (section-matrix (iup:matrix - #:alignment1 "ALEFT" - #:expand "YES" ;; "HORIZONTAL" - #:numcol 1 - #:numlin (length key-vals) - #:numcol-visible 1 - #:numlin-visible (min 10 (length key-vals)) + (key-vals (configf:section-vars rawconfig sectionname)) + (section-matrix (iup:matrix + #:alignment1 "ALEFT" + #:expand "YES" ;; "HORIZONTAL" + #:numcol 1 + #:numlin (length key-vals) + #:numcol-visible 1 + #:numlin-visible (min 10 (length key-vals)) #:scrollbar "YES"))) (iup:attribute-set! section-matrix "0:0" varcolname) (iup:attribute-set! section-matrix "0:1" valcolname) (iup:attribute-set! section-matrix "WIDTH1" "200") ;; fill in keys Index: gutils.scm ================================================================== --- gutils.scm +++ gutils.scm @@ -50,11 +50,14 @@ ((KILLREQ) (list "39 82 206" state)) ((KILLED) (list "234 101 17" state)) ((NOT_STARTED) (list "240 240 240" state)) ;; for xor mode below ;; - ((CLEAN) (list "60 235 63" status)) + ((CLEAN) + (case (string->symbol status) + ((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these + (else (list "60 235 63" status)))) ((DIRTY-BETTER) (list "160 255 153" status)) ((DIRTY-WORSE) (list "165 42 42" status)) ((BOTH-BAD) (list "180 33 49" status)) (else (list "192 192 192" state))))