Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -101,17 +101,25 @@ (define *last-db-update-time* 0) (define *please-update-buttons* #t) (define *db-file-path* (conc *toppath* "/megatest.db")) +(define *tests-sort-reverse* #f) + (define *verbosity* (cond ((args:get-arg "-debug")(string->number (args:get-arg "-debug"))) ((args:get-arg "-v") 2) ((args:get-arg "-q") 0) (else 1))) (define uidat #f) + +(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) +(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) +(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) +(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) + ;; (megatest-dashboard) ;(define img1 (iup:image/palette 16 16 (u8vector->blob (u8vector ; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 ; 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 @@ -215,21 +223,21 @@ (set! maxtests (length tests))) ;(if (not (null? tests)) (set! result (cons (vector run tests key-vals) result)))); ) runs) (set! *header* header) - (set! *allruns* result) + (set! *allruns* (if *tests-sort-reverse* (reverse result) result)) (debug:print 6 "*allruns* has " (length *allruns*) " runs") ;; (set! *tot-run-count* (+ 1 (length *allruns*))) maxtests)) *num-tests*))) ;; FIXME, naughty coding eh? (define *collapsed* (make-hash-table)) ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) (define (toggle-hide lnum) ; fulltestname) - (let* ((btn (vector-ref (vector-ref uidat 0) lnum)) + (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) (fulltestname (iup:attribute btn "TITLE")) (parts (string-split fulltestname "(")) (basetestname (if (null? parts) "" (car parts)))) ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) (if (hash-table-ref/default *collapsed* basetestname #f) @@ -292,29 +300,30 @@ ;; #t) ;; #t)))))) (define (update-labels uidat) (let* ((rown 0) - (lftcol (vector-ref uidat 0)) + (keycol (dboard:uidat-get-keycol uidat)) + (lftcol (dboard:uidat-get-lftcol uidat)) (numcols (vector-length lftcol)) (maxn (- numcols 1)) (allvals (make-vector numcols ""))) (for-each (lambda (name) (if (<= rown maxn) - (let ((labl (vector-ref lftcol rown))) - (vector-set! allvals rown name))) + (vector-set! allvals rown name)) ;) (set! rown (+ 1 rown))) *alltestnamelst*) - ; (if (> (length *alltestnamelst*) *start-test-offset*) - ; (drop *alltestnamelst* *start-test-offset*) - ; '())) (let loop ((i 0)) (let* ((lbl (vector-ref lftcol i)) + (keyval (vector-ref keycol i)) (oldval (iup:attribute lbl "TITLE")) (newval (vector-ref allvals i))) (if (not (equal? oldval newval)) - (iup:attribute-set! lbl "TITLE" newval)) + (let ((munged-val (let ((parts (string-split newval "("))) + (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) + (vector-set! keycol i newval) + (iup:attribute-set! lbl "TITLE" munged-val))) (iup:attribute-set! lbl "FGCOLOR" (if (hash-table-ref/default *collapsed* newval #f) "0 112 112" "0 0 0")) (if (< i maxn) (loop (+ i 1))))))) (define (get-color-for-state-status state status) @@ -338,13 +347,13 @@ (define (update-buttons uidat numruns numtests) (if *please-update-buttons* (let* ((runs (if (> (length *allruns*) numruns) (take-right *allruns* numruns) (pad-list *allruns* numruns))) - (lftcol (vector-ref uidat 0)) - (tableheader (vector-ref uidat 1)) - (table (vector-ref uidat 2)) + (lftcol (dboard:uidat-get-lftcol uidat)) + (tableheader (dboard:uidat-get-header uidat)) + (table (dboard:uidat-get-runsvec uidat)) (coln 0)) (set! *please-update-buttons* #f) (set! *alltestnamelst* '()) ;; create a concise list of test names (for-each @@ -438,10 +447,11 @@ (define (make-dashboard-buttons nruns ntests keynames) (let* ((nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) + (keycol (make-vector ntests)) (controls '()) (lftlst '()) (hdrlst '()) (bdylst '()) (result '()) @@ -459,13 +469,17 @@ (update-search "test-name" val))) (iup:textbox #:size "60x15" #:fontsize "10" #:value "%" #:action (lambda (obj unk val) (set! *last-db-update-time* 0) (update-search "item-name" val))))) - (iup:hbox - (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit))) - (iup:button "Monitor" #:action (lambda (obj)(system (conc (car (argv))" -guimonitor &")))) + (iup:vbox + (iup:hbox + (iup:button "Sort" #:acton (lambda (obj) + (set! *tests-sort-order* (not *tests-sort-order*))))) + (iup:hbox + (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit))) + (iup:button "Monitor" #:action (lambda (obj)(system (conc (car (argv))" -guimonitor &"))))) )) ;; (iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offset* (+ *start-run-offset* 1)))) ;; (iup:button "Up ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0)))) ;; (iup:button "Down v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1))))) ;; (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offset* (if (> *start-run-offset* 0)(- *start-run-offset* 1) 0)))) @@ -539,10 +553,11 @@ #:orientation "VERTICAL") (apply iup:vbox (reverse res))))))) (else (let ((labl (iup:button "" #:flat "YES" + #:alignment "ALEFT" ; #:image img1 ; #:impress img2 #:size "100x15" #:fontsize "10" #:action (lambda (obj) @@ -603,11 +618,11 @@ (iup:vbox ;; the header (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) controls))) - (vector lftcol header runsvec))) + (vector keycol lftcol header runsvec))) (if (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS" )) (begin (set! *num-tests* (string->number (or (args:get-arg "-rows")