Megatest

  (syntax-rules ()
    ((_ (name arg ...) body ...)
     (define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))

(define-syntax common:handle-exceptions
  (syntax-rules ()
    ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...))))

;; iup callbacks are not dumping the stack, this is a work-around
;;
(define-simple-syntax (debug:catch-and-dump proc procname)
  (handle-exceptions
   exn
   (begin
     (print-call-chain (current-error-port))
     (with-output-to-port (current-error-port)
       (lambda ()
	 (print ((condition-property-accessor 'exn 'message) exn))
	 (print "Callback error in " procname)
	 (print "Full condition info:\n" (condition->list exn)))))
   (proc)))

(define (debug:calc-verbosity vstr)
  (cond
   ((number? vstr) vstr)
   ((not (string?  vstr))   1)
   ;; ((string-match  "^\\s*$" vstr) 1)
   (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))

(defstruct dboard:runsdat
  ;; new system
  runs-index    ;; target/runname => colnum
  tests-index   ;; testname/itempath => rownum
  matrix-dat    ;; vector of vectors rows/cols
  )

(define (dboard:runsdat-make-init)
  (make-dboard:runsdat
   runs-index: (make-hash-table)
   tests-index: (make-hash-table)
   matrix-dat: (make-sparse-array)))

;; used to keep the rundata from rmt:get-tests-for-run
;; in sync. 
;;
(defstruct dboard:rundat
  run
  tests-drawn    ;; list of id's already drawn on screen
  tests-notdrawn ;; list of id's NOT already drawn
  tests          ;; hash of id => testdat
  tests-by-name  ;; hash of testfullname => testdat
  key-vals
  last-update    ;; last query to db got records from before last-update
  )

(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100))
  (make-dboard:rundat 
   run: run
   tests: (or tests (make-hash-table))
   tests-by-name: (make-hash-table)
   key-vals: key-vals 
   last-update: last-update)) ;; -100 is before time began

(define (dboard:rundat-copy-tests-to-by-name rundat)
  (let ((src-ht (dboard:rundat-tests rundat))
	(trg-ht (dboard:rundat-tests-by-name rundat)))
    (if (and (hash-table? src-ht)(hash-table? trg-ht))
	(for-each
	 (lambda (testdat)
	   (hash-table-set! trg-ht (test:test-get-fullname testdat) testdat))
	 (hash-table-values src-ht))
	(debug:print 0 *default-log-port* "WARNING: src-ht " src-ht " trg-ht " trg-ht))))
  
(defstruct dboard:testdat
  id       ;; testid
  state    ;; test state
  status   ;; test status
  )

(define (dboard:runsdat-get-col-num dat target runname force-set)

	 (sort-info   (get-curr-sort))
	 (sort-by     (vector-ref sort-info 1))
	 (sort-order  (vector-ref sort-info 2))
	 (bubble-type (if (member sort-order '(testname))
			  'testname
			  'itempath))
	 (run-dat    (let ((rec (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f)))
			(if rec rec (dboard:rundat-make-init run: run key-vals: key-vals))))
	 ;; (prev-tests  (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1))
	 (last-update (dboard:tabdat-last-update tabdat)) ;; (vector-ref prev-dat 3))
	 (tmptests    (rmt:get-tests-for-run run-id testnamepatt states statuses  ;; run-id testpatt states statuses
					     #f #f                                ;; offset limit 
					     (dboard:tabdat-hide-not-hide tabdat) ;; no-in
					     sort-by                              ;; sort-by
					     sort-order                           ;; sort-order

	    ;; (tests       (bubble-up tmptests priority: bubble-type))
	    ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
	    ;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
	    ;; Not sure this is needed?
	    (if (not (null? all-test-ids))
		(let* ((newmaxtests (max num-tests maxtests))
		       (last-update (- (current-seconds) 10))
		       (run-struct  (dboard:rundat-make-init
				     run:         run 
				     tests:       tests-ht
				     key-vals:    key-vals
				     last-update: last-update))
		       (new-res     (cons run-struct res))
		       (elapsed-time (- (current-seconds) start-time)))
		  (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct)

	 (table       (dboard:uidat-get-runsvec uidat))
	 (coln        0))
    (set! *alltestnamelst* '())
    ;; create a concise list of test names
    (for-each
     (lambda (rundat)
       (if rundat
	   (let* ((testdats  (dboard:rundat-tests rundat))
		  (testnames (map test:test-get-fullname (hash-table-values testdats)))
		  (alltests-by-name (make-hash-table)))
	     (dboard:rundat-copy-tests-to-by-name rundat)
	     ;; for the normalized list of testnames (union of all runs)
	     (if (not (and (dboard:tabdat-hide-empty-runs tabdat)
			   (null? testnames)))
		 (for-each (lambda (testname)
			     (if (not (member testname *alltestnamelst*))
				 (begin
				   (set! *alltestnamelst* (append *alltestnamelst* (list testname))))))
			   testnames)))))
     runs)

    ;; need alltestnames to enable lining up all tests from all runs
    (set! *alltestnamelst* (collapse-rows tabdat *alltestnamelst*)) ;;; argh. please clean up this sillyness
    (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) (dboard:tabdat-start-test-offset tabdat))
					 (drop *alltestnamelst* (dboard:tabdat-start-test-offset tabdat))
					 '())))
			     (append xl (make-list (- (dboard:tabdat-num-tests tabdat) (length xl)) ""))))
    (update-labels uidat)
    (for-each
     (lambda (rundat)
       (if (not rundat) ;; handle padded runs
	   ;;           ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration
	   (set! rundat (dboard:rundat-make-init
			 key-vals: (map (lambda (x) "")(dboard:tabdat-keys tabdat)))))
       (let* ((run              (dboard:rundat-run rundat))
	      (testsdat-by-name (dboard:rundat-tests-by-name rundat))
	      (key-val-dat      (dboard:rundat-key-vals rundat))
	      (run-id           (db:get-value-by-header run (dboard:tabdat-header tabdat) "id"))
	      (key-vals         (append key-val-dat
					(list (let ((x (db:get-value-by-header run (dboard:tabdat-header tabdat) "runname")))
						(if x x "")))))
	      (run-key          (string-intersperse key-vals "\n")))
	 
	 ;; fill in the run header key values
	 (let ((rown      0)
	       (headercol (vector-ref tableheader coln)))
	   (for-each (lambda (kval)
		       (let* ((labl      (vector-ref headercol rown)))
			 (if (not (equal? kval (iup:attribute labl "TITLE")))
			     (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval))
			 (set! rown (+ rown 1))))
		     key-vals))
	 
	 ;; For this run now fill in the buttons for each test
	 (let ((rown 0)
	       (columndat  (vector-ref table coln)))
	   (for-each
	    (lambda (testname)
	      (let ((buttondat  (hash-table-ref/default (dboard:tabdat-buttondat tabdat) (mkstr coln rown) #f)))
		(if (and buttondat
			 (hash-table? testsdat-by-name))
		    (let* ((testdat      (let ((matching (hash-table-ref/default testsdat-by-name testname #f)))
					   ;; (filter 
					   ;;   (lambda (x)(equal? (test:test-get-fullname x) testname))
					   ;;     testsdat)))
					   (if (not matching)
					       (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "")
					       ;; (car matching))))
					       matching)))
			   (testname     (db:test-get-testname   testdat))
			   (itempath     (db:test-get-item-path  testdat))
			   (testfullname (test:test-get-fullname testdat))
			   (teststatus   (db:test-get-status     testdat))
			   (teststate    (db:test-get-state      testdat))
			   ;;(teststart  (db:test-get-event_time test))
			   ;;(runtime    (db:test-get-run_duration test))
			   (buttontxt    (cond
					  ((member teststate '("COMPLETED" "ARCHIVED")) teststatus)
					  ((and (equal? teststate "NOT_STARTED")
						(member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES")))
					   teststatus)
					  (else
					   teststate)))
			   (button     (vector-ref columndat rown))
			   (color      (car (gutils:get-color-for-state-status teststate teststatus)))
			   (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR"))
			   (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE")))
		      (if (not (equal? curr-color color))
			  (iup:attribute-set! button "BGCOLOR" color))
		      (if (not (equal? curr-title buttontxt))
			  (iup:attribute-set! button "TITLE"   buttontxt))
		      (vector-set! buttondat 0 run-id)
		      (vector-set! buttondat 1 color)
		      (vector-set! buttondat 2 buttontxt)
		      (vector-set! buttondat 3 testdat)
		      (vector-set! buttondat 4 run-key)))
		(set! rown (+ rown 1))))
	    *alltestnamelst*))
	 (set! coln (+ coln 1))))
     runs)))

(define (mkstr . x)

		       (iup:listbox 
			#:size "45x50" 
			#:fontsize "10"
			#:expand "YES" ;; "VERTICAL"
			;; #:dropdown "YES"
			#:editbox "YES"
			#:action (lambda (obj a b c)
				   (debug:catch-and-dump action-proc "update-target-selector"))
			#:caret_cb (lambda (obj a b c)
				     (debug:catch-and-dump action-proc "update-target-selector"))
			))))
	     ;; loop though all the targets and build the list for this dropdown
	     (selected-value (dashboard:populate-target-dropdown lb refvals all-targets)))
	(if (null? remkeys)
	    ;; return a list of the listbox items and an iup:hbox with the labels and listboxes
	    (let ((listboxes (append lbs (list lb))))
	      (list listboxes

  (let ((alltgls (make-hash-table)))
    (apply iup:vbox
	   (map (lambda (item)
		  (iup:toggle 
		   item
		   #:expand "YES"
		   #:action (lambda (obj tstate)
			       (debug:catch-and-dump 
				(lambda ()
				  (if (eq? tstate 0)
				      (hash-table-delete! alltgls item)
				      (hash-table-set! alltgls item #t))
				  (let ((all (hash-table-keys alltgls)))
				    (proc all)))
				"text-list-toggle-box"))))
		items))))

;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
;;
(define (dashboard:update-run-command tabdat)
  (let* ((cmd-tb       (dboard:tabdat-command-tb tabdat))
	 (cmd          (dboard:tabdat-command    tabdat))

;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
(define (dashboard:run-times commondat tabdat #!key (tab-num #f))

  (let ((drawing               (vg:drawing-new))
	(run-times-tab-updater (debug:catch-and-dump 
				(lambda ()	
				  (let ((tabdat        (dboard:common-get-tabdat commondat tab-num: tab-num)))
				    (if tabdat
					(dashboard:run-times-tab-updater commondat tabdat tab-num))))
				"dashboard:run-times-tab-updater")))
    (dboard:tabdat-drawing-set! tabdat drawing)
    (dboard:commondat-add-updater commondat run-times-tab-updater tab-num: tab-num)
    (iup:split
     #:orientation "VERTICAL" ;; "HORIZONTAL"
     #:value 200
     (let* ((tb      (iup:treebox
		      #:value 0
		      #:name "Runs"
		      #:expand "YES"
		      #:addexpanded "NO"
		      #:selection-cb
		      (lambda (obj id state)
			(debug:catch-and-dump
			 (lambda ()
			   (let* ((run-path (tree:node->path obj id))










				  (run-id    (tree-path->run-id tabdat (cdr run-path))))
			     (print "run-path: " run-path)
			     (if (number? run-id)
				 (begin
				   (dboard:tabdat-curr-run-id-set! tabdat run-id)
				   ;; (dashboard:update-run-summary-tab)
				   )
				 (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))))
			 "treebox"))
			;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
		      )))
       (dboard:tabdat-runs-tree-set! tabdat tb)
       tb)
     (iup:vbox
      (let* ((cnv-obj (iup:canvas 
		       ;; #:size "500x400"
		       #:expand "YES"
		       #:scrollbar "YES"
		       #:posx "0.5"
		       #:posy "0.5"
		       #:action (make-canvas-action
				  (lambda (c xadj yadj)
				    (debug:catch-and-dump
				     (lambda ()
				       (if (not (dboard:tabdat-cnv tabdat))
					   (dboard:tabdat-cnv-set! tabdat c))
				       (let ((drawing (dboard:tabdat-drawing tabdat))
					     (old-xadj (dboard:tabdat-xadj   tabdat))
					     (old-yadj (dboard:tabdat-yadj   tabdat)))
					 (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj)))
					     (begin
					       (print  "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj))
					       (dboard:tabdat-view-changed-set! tabdat #t)
					       (dboard:tabdat-xadj-set! tabdat (* -1000 (- xadj 0.5)))
					       (dboard:tabdat-yadj-set! tabdat (*  1000 (- yadj 0.5)))
					       ))))
				     "iup:canvas action")))
		       #:wheel-cb  (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
				     (debug:catch-and-dump
				      (lambda ()
					(let* ((drawing (dboard:tabdat-drawing tabdat))
					       (scalex  (vg:drawing-scalex drawing)))
					  (dboard:tabdat-view-changed-set! tabdat #t)
					  (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex)
					  (vg:drawing-scalex-set! drawing
								  (+ scalex
								     (if (> step 0)
									 (* scalex  0.02)
									 (* scalex -0.02))))))
				      "wheel-cb"))
		       )))
	cnv-obj)))))

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;

		     ;; #:size "500x400"
		     #:expand "YES"
		     #:scrollbar "YES"
		     #:posx "0.5"
		     #:posy "0.5"
		     #:action (make-canvas-action
			       (lambda (c xadj yadj)
				 (debug:catch-and-dump
				  (lambda ()
				    (if (not (dboard:tabdat-cnv tabdat))
					(dboard:tabdat-cnv-set! tabdat c))
				    (let ((drawing (dboard:tabdat-drawing tabdat))
					  (old-xadj (dboard:tabdat-xadj   tabdat))
					  (old-yadj (dboard:tabdat-yadj   tabdat)))
				      (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj)))
					  (begin
					    (print  "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj))
					    (dboard:tabdat-view-changed-set! tabdat #t)
					    (dboard:tabdat-xadj-set! tabdat (* -500 (- xadj 0.5)))
					    (dboard:tabdat-yadj-set! tabdat (*  500 (- yadj 0.5)))
					    ))))
				  "iup:canvas action dashboard:one-run")))
		     #:wheel-cb (lambda (obj step x y dir) ;; dir is 4 for up and 5 for down. I think.
				  (debug:catch-and-dump
				   (lambda ()
				     (let* ((drawing (dboard:tabdat-drawing tabdat))
					    (scalex  (vg:drawing-scalex drawing)))
				       (dboard:tabdat-view-changed-set! tabdat #t)
				       (print "step: " step " x: " x " y: " y " dir: " dir " scalex: " scalex)
				       (vg:drawing-scalex-set! drawing
							       (+ scalex
								  (if (> step 0)
								      (* scalex  0.02)
								      (* scalex -0.02))))))
				   "dashboard:one-run wheel-cb"))
		     )))
       cnv-obj))))

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;

	   (iup:vbox
	    (iup:frame 
	     #:title "filter test and items"
	     (iup:hbox
	      (iup:vbox
	       (iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
			    #:action (lambda (obj unk val)
				       (debug:catch-and-dump
					(lambda ()
					  (mark-for-update tabdat)
					  (update-search commondat tabdat "test-name" val))
					"make-controls")))
	       (iup:hbox
		(iup:button "Quit"      #:action (lambda (obj)
						   ;; (if (dboard:tabdat-dblocal tabdat) (db:close-all (dboard:tabdat-dblocal tabdat)))
						   (exit)))
		(iup:button "Refresh"   #:action (lambda (obj)
						   (mark-for-update tabdat)))
		(iup:button "Collapse"  #:action (lambda (obj)
						   (debug:catch-and-dump 
						    (lambda ()
						      (let ((myname (iup:attribute obj "TITLE")))
							(if (equal? myname "Collapse")
							    (begin
							      (for-each (lambda (tname)
									  (hash-table-set! *collapsed* tname #t))
									(dboard:tabdat-item-test-names tabdat))
							      (iup:attribute-set! obj "TITLE" "Expand"))
							    (begin
							      (for-each (lambda (tname)
									  (hash-table-delete! *collapsed* tname))
									(hash-table-keys *collapsed*))
							      (iup:attribute-set! obj "TITLE" "Collapse"))))
						      (mark-for-update tabdat))
						    "make-controls collapse button"))))
	       )
	      (iup:vbox
	       ;; (iup:button "Sort -t"   #:action (lambda (obj)
	       ;;   				 (next-sort-option)
	       ;;   				 (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0))
	       ;;   				 (mark-for-update tabdat)))
	       

						   (mark-for-update tabdat))))
		 (iup:attribute-set! hide "BGCOLOR" sel-color)
		 (iup:attribute-set! show "BGCOLOR" nonsel-color)
		 ;; (dboard:tabdat-hide-not-hide-button-set! tabdat hideit) ;; never used, can eliminate ...
		 (iup:vbox
		  (iup:hbox hide show)
		  hide-empty sort-lb)))
	       )))
	   (iup:frame 
	    #:title "state/status filter"
	    (iup:vbox
	     (apply 
	      iup:hbox
	      (map (lambda (status)
		     (iup:toggle (conc status "  ")

					(apply iup:hbox (reverse hdrlst))
					(apply iup:hbox (reverse bdylst))))))
			 ;; controls
			 ))
	     ;; (data (dboard:tabdat-init (make-d:data)))
	     (tabs (iup:tabs
		    #:tabchangepos-cb (lambda (obj curr prev)
					(debug:catch-and-dump
					 (lambda ()
					   (dboard:commondat-please-update-set! commondat #t)
					   (dboard:commondat-curr-tab-num-set! commondat curr))
					 "tabchangepos"))
		    (dashboard:summary commondat stats-dat tab-num: 0)
		    runs-view
		    (dashboard:one-run commondat onerun-dat tab-num: 2)
		    ;; (dashboard:new-view db data new-view-dat tab-num: 3)
		    (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
		    (dashboard:run-times commondat runtimes-dat tab-num: 4)
		    )))

					(dboard:sort-testsdat-by-event-time item-tests testsdat)))))))
	 (hash-table-keys test-ids-by-name))
	(sort (hash-table-values test-ids-by-name)
	      (lambda (a b)
		(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
		   (db:test-get-event_time (hash-table-ref testsdat (car b))))))))))

(define (dashboard:run-times-tab-updater commondat tabdat tab-num)
  ;; each test is an object in the run component
  ;; each run is a component
  ;; all runs stored in runslib library

  (let* ((canvas-margin 10)
	 (start-row     0) ;; each run starts in this row
	 (run-start-row 0)
	 (max-row       0) ;; the max row seen for this run
	 (row-height    10)
	 (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
	 (runs-hash     (let ((ht (make-hash-table)))

	      (canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj)
	      (print "Number of objs: " (length (vg:draw (dboard:tabdat-drawing tabdat) #t)))
	      (dboard:tabdat-view-changed-set! tabdat #f)
	      )))
	(debug:print 2 *default-log-port* "no tabdat for run-times-tab-updater"))))

(define (dashboard:runs-tab-updater commondat tab-num)
  (debug:catch-and-dump 
   (lambda ()
     (let ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)))
       (update-rundat tabdat (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") (dboard:tabdat-numruns tabdat)
		      (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
		      ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
		      (let ((res '()))
			(for-each (lambda (key)
				    (if (not (equal? key "runname"))
					(let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
					  (if val (set! res (cons (list key val) res))))))
				  (dboard:tabdat-dbkeys tabdat))
			res))
       (let ((uidat (dboard:commondat-uidat commondat)))
	 (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
       ))
   "dashboard:runs-tab-updater"))

;; ((2)
;;  (dashboard:update-run-summary-tab))
;; ((3)
;;  (dashboard:update-new-view-tab))
;; (else
;;  (dboard:common-run-curr-updater commondat)))