Overview
| Comment: | wip |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | xor-two-runs |
| Files: | files | file ages | folders |
| SHA1: |
26c23ee62d7190508fb435507bae12a5 |
| User & Date: | bjbarcla on 2016-09-02 18:10:57 |
| Other Links: | branch diff | manifest | tags |
Context
|
2016-09-06
| ||
| 12:58 | xor looking good; still need to fixup slider lock issue check-in: 95351f9ba6 user: bjbarcla tags: xor-two-runs | |
|
2016-09-02
| ||
| 18:10 | wip check-in: 26c23ee62d user: bjbarcla tags: xor-two-runs | |
|
2016-08-26
| ||
| 17:51 | wip check-in: 4267e55d27 user: bjbarcla tags: xor-two-runs | |
Changes
Modified dashboard.scm from [1ccdb1c663] to [6533588be6].
| ︙ | ︙ | |||
1154 1155 1156 1157 1158 1159 1160 |
;; (let ((logs-tb (iup:textbox #:expand "YES"
;; #:multiline "YES")))
;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
;; logs-tb))
)))
(define (dboard:xor-ui-update tabdat)
| < | | | | | | < < < < < < | | 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
;; (let ((logs-tb (iup:textbox #:expand "YES"
;; #:multiline "YES")))
;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
;; logs-tb))
)))
(define (dboard:xor-ui-update tabdat)
(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 (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 (if prev-run-id
(rmt:get-run-name-from-id prev-run-id)
"None"))
)
(print "BB> xor-ui-update HELLO" )
(print "BB> curr-runname="curr-runname)
(print "BB> prev-runname="prev-runname)
(print "BB> current-mode="current-mode)
(case current-mode
((view-one-run)
(iup:attribute-set! xor-src-runid-label "TITLE" "")
(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?"))
)))
(define (dboard:runs-tree-browser commondat tabdat)
(let* ((tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
|
| ︙ | ︙ | |||
1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 |
(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")))))
(define (dashboard:xor-two-runs-updater commondat tabdat tb cell-lookup run-matrix )
(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
| > > > > | | > | > > | 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 |
(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")))))
(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
(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
(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))))
(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)
|
| ︙ | ︙ | |||
1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 |
))))
(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
(iup:vbox
tb)
run-matrix)
mode-selector)
))
| > | 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 |
))))
(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)
))
|
| ︙ | ︙ |
Modified dcommon.scm from [29b42dc17c] to [7e012ba591].
| ︙ | ︙ | |||
280 281 282 283 284 285 286 287 288 289 290 291 292 293 |
(state (db:test-get-status hed))
(status (db:test-get-status hed))
(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: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))
(let*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
(state (db:test-get-status hed))
(status (db:test-get-status hed))
(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")
(exit 1))
(let*
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
(message-window (conc "Directory " rundir " not found"))))))
(xterm)
(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"))
(keys-matrix (iup:matrix
#:alignment1 "ALEFT"
| > > | 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
(message-window (conc "Directory " rundir " not found"))))))
(xterm)
(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"))
(keys-matrix (iup:matrix
#:alignment1 "ALEFT"
|
| ︙ | ︙ |