Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1156,28 +1156,25 @@ ;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb) ;; logs-tb)) ))) (define (dboard:xor-ui-update tabdat) - (print "BB> ARGH0") (let* ((mode-flag (dboard:tabdat-mode-flag tabdat)) (current-mode (mode-flag)) (xor-src-runid-label (dboard:tabdat-xor-src-runid-label tabdat)) (xor-dest-runid-label (dboard:tabdat-xor-dest-runid-label tabdat)) - (curr-run-id (begin (print "BB> ARGH1") (dboard:tabdat-curr-run-id tabdat))) - (prev-run-id (begin (print "BB> ARGH2") (dboard:tabdat-prev-run-id tabdat))) - (curr-runname (begin (print "BB> ARGH3") (if curr-run-id + (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"))) - (prev-runname (begin (print "BB> ARGH4") (if prev-run-id + "None")) + (prev-runname (if prev-run-id (rmt:get-run-name-from-id prev-run-id) - "None"))) + "None")) ) (print "BB> xor-ui-update HELLO" ) - (print "BB> xor-src-runid-label="xor-src-runid-label) - (print "BB> xor-dest-runid-label="xor-dest-runid-label) (print "BB> curr-runname="curr-runname) (print "BB> prev-runname="prev-runname) (print "BB> current-mode="current-mode) (case current-mode ((view-one-run) @@ -1185,15 +1182,11 @@ (iup:attribute-set! xor-dest-runid-label "TITLE" "")) ((xor-two-runs) (iup:attribute-set! xor-src-runid-label "TITLE" (conc " SRC: "curr-runname" ")) (iup:attribute-set! xor-dest-runid-label "TITLE" (conc "DEST: "prev-runname" "))) (else (print "BB> WHA?")) - ) - (print "BB> after case") - - - )) + ))) (define (dboard:runs-tree-browser commondat tabdat) (let* ((tb (iup:treebox #:value 0 #:name "Runs" @@ -1503,22 +1496,29 @@ (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"))))) + + + (define (dashboard:xor-two-runs-updater commondat tabdat tb cell-lookup run-matrix ) + (print "BB> HeLLooo from xor-two-runs-updater") (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 (prev-run-id (dboard:tabdat-prev-run-id tabdat)) (curr-run-id (dboard:tabdat-curr-run-id tabdat)) (last-update 0) ;; fix me - have to create and store a rundat record for this - (curr-tests-dat (dboard:get-tests-dat tabdat curr-run-id last-update)) ;; does query to get run info - (prev-tests-dat (dboard:get-tests-dat tabdat prev-run-id last-update)) ;; does query to get run info + (dest-tests-dat (dboard:get-tests-dat tabdat curr-run-id last-update)) ;; does query to get run info + (src-tests-dat (dboard:get-tests-dat tabdat prev-run-id last-update)) ;; does query to get run info ;;; STOPPED HERE - (tests-mindat (dcommon:minimize-test-data curr-tests-dat)) ;; reduces data for display + (dest-tests-mindat (dcommon:minimize-test-data dest-tests-dat)) ;; reduces data for display + (src-tests-mindat (dcommon:minimize-test-data src-tests-dat)) ;; reduces data for display + ;;(tests-mindat dest-tests-mindat) + (tests-mindat (dcommon:xor-tests-mindat src-tests-mindat dest-tests-mindat)) ;; TODO: flags for common, modified, new -- like meld (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)))) @@ -1731,10 +1731,11 @@ (dboard:commondat-add-updater commondat one-run-updater tab-num: tab-num) ;; register updater (dboard:tabdat-runs-tree-set! tabdat tb) (iup:vbox (iup:split + #:value 150 (iup:vbox tb) run-matrix) mode-selector) )) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -282,10 +282,105 @@ (newitem (list test-name item-path (list test-id state status)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) + +(define (dcommon:tests-mindat->hash tests-mindat) + (let* ((res (make-hash-table))) + (for-each + (lambda (item) + (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) + (value (list-ref item 2))) + (hash-table-set! res test-name+item-path value))) + tests-mindat) + res)) + +;; return 1 if status1 is better +;; return 0 if status1 and 2 are equally good +;; return -1 if status2 is better +(define (dcommon:status-compare3 status1 status2) + (let* + ((status-goodness-ranking (list "PASS" "WARN" "WAIVED" "SKIP" "FAIL" "ABORT" #f)) + (mem1 (member status1 status-goodness-ranking)) + (mem2 (member status2 status-goodness-ranking)) + ) + (cond + ((and (not mem1) (not mem2)) 0) + ((not mem1) -1) + ((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) + (let* ((src-hash (dcommon:tests-mindat->hash src-tests-mindat)) + (dest-hash (dcommon:tests-mindat->hash dest-tests-mindat)) + (all-keys + (sort + (delete-duplicates + (append (hash-table-keys src-hash) (hash-table-keys dest-hash))) + (lambda (a b) + (if (= -1 (string-compare3 (car a) (car b))) + #t + (if (= -1 (string-compare3 (cdr a) (cdr b))) + #t + #f)))))) + (pretty-print all-keys) + (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 "COMPLETE") + (not (member dest-status incomplete-statuses)))) + (src-complete + (and src-value src-state src-status + (equal? src-state "COMPLETE") + (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 dest-state (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))) + (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") @@ -311,10 +406,12 @@ (print "Adding xterm code"))))) ;;====================================================================== ;; D A T A T A B L E S ;;====================================================================== + + ;; Table of keys (define (dcommon:keys-matrix rawconfig) (let* ((curr-row-num 1) (key-vals (configf:section-vars rawconfig "fields"))