Megatest

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2012-2016

Usage: dashboard [options]
  -h                    : this help

  -test run-id,test-id  : control test identified by testid

  -skip-version-check   : skip the version check

Misc
  -rows N         : set number of rows
"))

;;   -server host:port     : connect to host:port instead of db access
;;   -xterm run-id,test-id : Start a new xterm with specified run-id and test-id
;;   -guimonitor           : control panel for runs

;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-rows"
			"-run"
			"-test"
                        "-xterm"
			"-debug"
			"-host" 
			"-transport"
			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
			"-use-local"
			"-skip-version-check"
			)
		 args:arg-hash
		 0))

(if (args:get-arg "-h")
    (begin
      (print help)

;; gets and calls updater based on curr-tab-num
(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
  (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
      (let* ((tnum     (or tab-num (dboard:commondat-curr-tab-num commondat)))
	     (updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
					       tnum
					       '())))
	(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
	(for-each
	 (lambda (updater)
	   (debug:print 3 *default-log-port* "Running " updater)
	   (updater)
	   )

	 updaters))))

    (hash-table-set! (dboard:commondat-updaters commondat)
		     tnum
		     (cons updater curr-updaters))))

;; data for each specific tab goes here
;;
(defstruct dboard:tabdat 
  ;; runs
  allruns          ;; list of dboard:rundat records
  allruns-by-id    ;; hash of run-id -> dboard:rundat records
  header           ;; header for decoding the run records
  keys             ;; keys for this run (i.e. target components)
  numruns

  ;; Runs view
  buttondat 
  item-test-names

  ;; Canvas and drawing data
  cnv
  cnv-obj
  drawing
  draw-cache     ;; 

  ;; Controls used to launch runs etc.
  command
  command-tb 

  ;; Selector variables
  curr-run-id      ;; current row to display in Run summary view
  curr-test-ids    ;; used only in dcommon:run-update which is used in newdashboard
  filters-changed  ;; to to indicate that the user changed filters for this tab
  hide-empty-runs
  hide-not-hide    ;; toggle for hide/not hide empty runs
  hide-not-hide-button

  ;; db info to file the .db files for the area
  dbdir
  dbfpath
  dbkeys 








  last-db-update  ;; last db file timestamp
  monitor-db-path ;; where to find monitor.db

  ;; tests data
  last-update      ;; last time rmt:get-tests-for-run was used to get data


  num-tests

  path-run-ids
  ro
  run-keys
  run-name
  runs
  runs-listbox
  runs-matrix 

  )

;; used to keep the rundata from rmt:get-tests-for-run
;; in sync. 
;;
(defstruct dboard:rundat
  run
  tests-drawn
  tests  
  key-vals
  last-update
  )

(define (dboard:runsdat-make-init)
  (make-dboard:runsdat
   runs-index: (make-hash-table)

		      #:name "Runs"
		      #:expand "YES"
		      #:addexpanded "NO"
		      #:selection-cb
		      (lambda (obj id state)
			;; (print "obj: " obj ", id: " id ", state: " state)
			(let* ((run-path (tree:node->path obj id))




			       ;; change this to store run-path appropriately as selector





			       (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)
				)

	 (run-ids       (sort (filter number? (hash-table-keys runs-hash))
			      (lambda (a b)
				(let* ((record-a (hash-table-ref runs-hash a))
				       (record-b (hash-table-ref runs-hash b))
				       (time-a   (db:get-value-by-header record-a runs-header "event_time"))
				       (time-b   (db:get-value-by-header record-b runs-header "event_time")))
				  (< time-a time-b)))))
	 (tb            (dboard:tabdat-runs-tree tabdat))
	 (num-runs      (length (hash-table-keys runs-hash)))
	 (run-num       0)
	 (update-start-time (current-seconds)))
    ;; fill in the tree
    (if tb (for-each (lambda (run-id)
		       (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
			      (key-vals   (map (lambda (key)(db:get-value-by-header run-record runs-header key))
					       (dboard:tabdat-keys tabdat)))
			      (run-name   (db:get-value-by-header run-record runs-header "runname"))
			      (col-name   (conc (string-intersperse key-vals "\n") "\n" run-name))

			       ;; Here we update the tests treebox and tree keys
			       (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name))
					      userdata: (conc "run-id: " run-id))
			       (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
			       ;; (set! colnum (+ colnum 1))
			       ))))
		     run-ids))
    ;;
    (if (and tabdat
	     (dboard:tabdat-view-changed tabdat))
	(let* ((drawing    (dboard:tabdat-drawing tabdat))
	       (runslib    (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
	       (compute-start (current-seconds)))
	  (vg:drawing-xoff-set! drawing (dboard:tabdat-xadj tabdat))
	  (vg:drawing-yoff-set! drawing (dboard:tabdat-yadj tabdat))
	  (print "Updating rundat")
	  (time (update-rundat tabdat
			 "%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%") 
			 100  ;; (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 ((allruns (dboard:tabdat-allruns tabdat))
		(rowhash (make-hash-table)) ;; store me in tabdat
		(cnv     (dboard:tabdat-cnv tabdat)))
	    (print "allruns: " allruns)
	    (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
			 ((originx originy)             (canvas-origin cnv)))
	      ;; (print "allruns: " allruns)

			    (run-end    (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))
			    (timeoffset (- (+ originx canvas-margin) run-start))
			    (run-duration (- run-end run-start))
			    (timescale  (/ (- sizex (* 2 canvas-margin))
					   (if (> run-duration 0)
					       run-duration
					       (current-seconds)))) ;; a least lously guess
			    (maptime    (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
			    (num-tests  (length hierdat))
			    (test-num   0)
			    (tot-tests  (length testsdat)))
		       (set! run-num (+ run-num 1))
		       ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
		       (vg:add-comp-to-lib runslib run-full-name runcomp)
		       (set! run-start-row (+ max-row 2))
		       (set! start-row run-start-row)
		       ;; this is the run title. move this into the box
		;; (let ((x 10)
		;; 	     (y (- sizey (* start-row row-height))))
		;; 	 (vg:add-objs-to-comp runcomp (vg:make-text x y run-full-name font: "Helvetica -10"))
		;; 	 (dashboard:add-bar rowhash start-row x (+ x 100)))
		       (set! start-row (+ start-row 1))
		       ;; get tests in list sorted by event time ascending
		       (for-each 
			(lambda (testdats)
			  (let ((test-objs   '())
				(iterated     (> (length testdats) 1))
				(first-rownum #f)
				(num-items    (length testdats))
				(item-num     0))
			    (set! test-num (+ test-num 1))
			    (for-each 
			     (lambda (testdat)
			       (let* ((event-time   (maptime (db:test-get-event_time   testdat)))
				      (run-duration (* timescale (db:test-get-run_duration testdat)))
				      (end-time     (+ event-time run-duration))
				      (test-name    (db:test-get-testname     testdat))
				      (item-path    (db:test-get-item-path    testdat))
				      (state         (db:test-get-state       testdat))
				      (status        (db:test-get-status      testdat))
				      (test-fullname (conc test-name "/" item-path))
				      (name-color    (gutils:get-color-for-state-status state status)))
				 (set! item-num (+ item-num 1))
				 ;; (print "event_time: " (db:test-get-event_time   testdat) " mapped event_time: " event-time)
				 ;; (print "run-duration: "  (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
				 (if (> item-num 50)
				     (if (eq? 0 (modulo item-num 50))
					 (print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
				 (let loop ((rownum run-start-row)) ;; (+ start-row 1)))
				   (set! max-row (max rownum max-row)) ;; track the max row used
				   (print "Allocating test")
				   (time (if (dashboard:row-collision rowhash rownum event-time end-time)
				       (loop (+ rownum 1))
				       (let* ((lly (- sizey (* rownum row-height)))
					      (uly (+ lly row-height))
					      (obj (vg:make-rect-obj event-time lly end-time uly
									    fill-color: (vg:iup-color->number (car name-color))
									    text: (if iterated item-path test-name)
									    font: "Helvetica -10")))
					 ;; (if iterated
					 ;;     (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items))
					 (if (not first-rownum)
					     (begin
					       (dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items)
					       (set! first-rownum rownum)))
					 (dashboard:add-bar rowhash rownum event-time end-time)
					 (vg:add-obj-to-comp runcomp obj)
					 (set! test-objs (cons obj test-objs))))))
				 ;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
				 ))
			   testdats)
			    ;; If it is an iterated test put box around it now.
			    (if iterated
				(let* ((xtents (vg:get-extents-for-objs drawing test-objs))
				       (llx (- (car xtents)   5))
				       (lly (- (cadr xtents) 10))
				       (ulx (+ 5 (caddr xtents)))
				       (uly (+ 0 (cadddr xtents))))
				  (dashboard:add-bar rowhash first-rownum llx ulx num-rows:  num-items)
				  (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
									     text:  (db:test-get-testname (car testdats))
									     font: "Helvetica -10"))))))
			hierdat)
		       ;; placeholder box
		       (set! max-row (+ max-row 1))
		       (let ((y   (- sizey (* max-row row-height))))
			 (vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
		       ;; instantiate the component 
		       (let* ((extents   (vg:components-get-extents drawing runcomp))
			      ;; move the following into mapping functions in vg.scm
			     ;; (deltax    (- llx ulx))
			     ;; (scalex    (if (> deltax 0)(/ sizex deltax) 1))
			     ;; (sllx      (* scalex llx))
			     ;; (offx      (- sllx originx))
			      (new-xtnts (apply vg:grow-rect 5 5 extents))
			      (llx       (list-ref new-xtnts 0))
			      (lly       (list-ref new-xtnts 1))
			      (ulx       (list-ref new-xtnts 2))
			      (uly       (list-ref new-xtnts 3))
			      ) ;;  (vg:components-get-extents d1 c1)))
			 (vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name))
			 (vg:instantiate drawing "runslib" run-full-name run-full-name 0 0))
		       (set! max-row (+ max-row 1)))))
	       allruns)
	      (vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj)
	      (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)

;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
  (if (file-exists? debugcontrolf)
      (load debugcontrolf)))

(define (main)
  (if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed))
  (let* ((commondat       (dboard:commondat-make)))
    ;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
    (cond 
     ((args:get-arg "-test") ;; run-id,test-id
      (let* ((dat     (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
			(if (> (length d) 1)
			    d