Index: diff-report.scm ================================================================== --- diff-report.scm +++ diff-report.scm @@ -13,50 +13,177 @@ ;; megatest -repl << EOF ;; TODO:dashboard not on homehost message exit + +(define (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 (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 (xor-tests-mindat src-tests-mindat dest-tests-mindat #!key (hide-clean #f)) + (let* ((src-hash (tests-mindat->hash src-tests-mindat)) + (dest-hash (tests-mindat->hash dest-tests-mindat)) + (all-keys + (reverse (sort + (delete-duplicates + (append (hash-table-keys src-hash) (hash-table-keys dest-hash))) + + (lambda (a b) + (cond + ((< 0 (string-compare3 (car a) (car b))) #t) + ((> 0 (string-compare3 (car a) (car b))) #f) + ((< 0 (string-compare3 (cdr a) (cdr b))) #t) + (else #f))) + + )))) + (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 (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))) + + (if hide-clean + (filter + (lambda (item) + ;;(print item) + (not + (equal? + "CLEAN" + (list-ref (list-ref item 2) 1)))) + res) + res)))) + (define (run-name->run-id runname) (let* ((qry-res (rmt:get-runs runname 1 0 '()))) (if (eq? 2 (vector-length qry-res)) (vector-ref (car (vector-ref qry-res 1)) 1) #f))) -(define (run-name->test-ht runname) - (let* ((ht (make-hash-table)) - (run-id (run-name->run-id runname)) + + +(define (run-name->tests-mindat runname) + (let* ((run-id (run-name->run-id runname)) (testpatt "%/%") - (states '("COMPLETED" "INCOMPLETE")) - (statuses '("PASS" "FAIL" "ABORT" "SKIP")) +;; (states '("COMPLETED" "INCOMPLETE")) + ;; (statuses '("PASS" "FAIL" "ABORT" "SKIP")) + (states '()) + (statuses '()) (offset #f) (limit #f) - (not-in #f) + (not-in #t) (sort-by #f) (sort-order #f) + (qryvals "id,testname,item_path,state,status") (qryvals "id,testname,item_path,state,status") (last-update 0) (mode #f) ) (print run-id) - (print (rmt:get-tests-for-run run-id - testpatt states statuses - offset limit - not-in sort-by sort-order - qryvals - last-update - mode)) + (map + (lambda (row) + (let* ((id (vector-ref row 0)) + (test-name (vector-ref row 1)) + (item-path (vector-ref row 2)) + (state (vector-ref row 3)) + (status (vector-ref row 4))) + ;;(hash-table-set! ht (cons testname item_path) (list id state status)) + (list test-name item-path (list id state status)) + ;;(print testname id)) + )) + (rmt:get-tests-for-run run-id + testpatt states statuses + offset limit + not-in sort-by sort-order + qryvals + last-update + mode)) ;(print (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in "%" "%" #f "id,testname,testpath,state,status" 0 'normal)) ;(print run-id) + )) -(run-name->test-ht "all57") +(print (run-name->tests-mindat "all60")) - - +(let* ((src-tests-mindat (run-name->tests-mindat "all57")) + (dest-tests-mindat (run-name->tests-mindat "all60"))) + (print (xor-tests-mindat src-tests-mindat dest-tests-mindat)));; #!key (hide-clean #f)) ;;(exit) ;;EOF