Megatest

(declare (uses itemsmod))
(declare (uses launchmod))
(declare (uses mtargs))
(declare (uses mtmod))
(declare (uses mtver))
(declare (uses processmod))
(declare (uses runsmod))
(declare (uses rmtmod))
(declare (uses subrunmod))
(declare (uses tree))
(declare (uses vgmod))

;; (declare (uses dashboard-guimonitor))
;; (declare (uses dashboard-main))

(import (prefix iup iup:))
(import canvas-draw)

;; (import canvas-draw-iup)

(import ducttape-lib
	bigmod)

(import (prefix sqlite3 sqlite3:)
	srfi-1
	chicken.file.posix
	chicken.string
	chicken.process-context
	chicken.process-context.posix
	regex regex-case srfi-69
	typed-records
	sparse-vectors
	format)
	format
	srfi-4
	)

;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
;; (include "task_records.scm")
;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")

	itemsmod
	launchmod
	(prefix mtargs args:)
	mtmod
	mtver
	processmod
	runsmod
	rmtmod
	subrunmod
	vgmod
	dcommon
	tree
	dashboard-context-menu
	dashboard-tests)

	 (lambda (updater)
	   ;; (debug:print 3 *default-log-port* "Running " updater)
	   (updater))
	 updaters))))

;; register tabdat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
#;(hash-table-set! *BBpp_custom_expanders_list* TABDAT:
                 (cons dboard:tabdat?
                       (lambda (tabdat-item)
                         (filter
                          (lambda (alist-entry)
                            (member (car alist-entry)
                                    '(allruns-by-id allruns))) ;; FIELDS OF INTEREST
                          (dboard:tabdat->alist tabdat-item)))))

(define (dboard:setup-tabdat tabdat)
  (dboard:tabdat-dbdir-set! tabdat (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
  (dboard:tabdat-dbfpath-set! tabdat (common:get-db-tmp-area))
  (dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))

  ;; HACK ALERT: this is a hack, please fix.
  (dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
  (dboard:tabdat-ro-set! tabdat (not (file-readable? (dboard:tabdat-dbfpath tabdat))))
  
  (dboard:tabdat-keys-set! tabdat (rmt:get-keys))
  (dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
  (dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
  )

;; RADT => Matrix defstruct addition

  status
  start-time
  duration
  )

;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
#;(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
                 (cons dboard:rundat?
                       (lambda (tabdat-item)
                         (filter
                          (lambda (alist-entry)
                            (member (car alist-entry)
                                    '(run run-data-offset ))) ;; FIELDS OF INTEREST
                          (dboard:rundat->alist tabdat-item)))))

;;======================================================================
;; S U M M A R Y 
;;======================================================================
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
  (let* ((rawconfig        (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
  (let* ((rawconfig        (configf:read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
	 (changed          #f))
    (iup:vbox
     (iup:split
      #:value 300
      (iup:frame 
       #:title "General Info"
       (iup:vbox

(define (dboard:add-external-tab commondat view-name views-cfgdat tabs tab-num)
  (let* ((success #t) ;; at any stage of the process set this flag to #f to skip downstream steps. Intention here is to recover gracefully if user provided tabs fail to load.
	 (source  (configf:lookup views-cfgdat view-name "source"))
	 (viewgen (configf:lookup views-cfgdat view-name "viewgen"))
	 (updater (configf:lookup views-cfgdat view-name "updater"))
	 (result-child #f))
    (if (and (common:file-exists? source)
	     (file-read-access? source))
	     (file-readable? source))
	(handle-exceptions
	 exn
	 (begin
	   (print-call-chain)
	   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn)
	   (debug:print 0 *default-log-port* "ERROR: failed to load " source ", try loading in the repl: megatest -repl")
	   (set! success #f))

	 (dbpth (if (< (length parts) 2) ;; assume then a filename was provided
		    dbstr
		    (if (equal? (car parts) "sqlite3")
			(cadr parts)
			(begin
			  (debug:print 0 *default-log-port* "ERROR: I only know sqlite3 databases for now: " dbstr)
			  #f)))))
    (if (and dbpth (file-read-access? dbpth))
    (if (and dbpth (file-readable? dbpth))
	(let ((db (sqlite3:open-database dbpth))) ;; (open-database dbpth)))
	  (sqlite3:set-busy-handler! db (make-busy-timeout 10000))
	  db)
	#f)))

;; sqlite3:path tablename timefieldname varfieldname field1 field2 ...
;;

;;======================================================================
;; The heavy lifting starts here
;;======================================================================

(define (main)
  (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; 
    (if (and (common:file-exists? mtdb-path)
	     (file-write-access? mtdb-path))
    #;(if (and (common:file-exists? mtdb-path)
	     (file-writable? mtdb-path))
	(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") ",")))) 

(declare (unit debugprint))
(declare (uses mtargs))

(module debugprint
	*
	
;;(import scheme chicken data-structures extras files ports)
(import scheme
	chicken.base
	chicken.string
	chicken.port
	chicken.process-context
	mtargs
	(prefix mtargs args:)
	srfi-1
	)

;;======================================================================
;; debug stuff
;;======================================================================

(define verbosity (make-parameter '()))
(define *default-log-port*  (current-error-port))
	 
(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
      		      (args:get-arg "-debug-noprop")
      		      (get-environment-variable "MT_DEBUG_MODE"))))
    (verbosity (debug:calc-verbosity debugstr 'q))
    (debug:check-verbosity (verbosity) debugstr)
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (verbosity)(verbosity 1))
    (if (and (not (args:get-arg "-debug-noprop"))
      	     (or (args:get-arg "-debug")
      		 (not (get-environment-variable "MT_DEBUG_MODE"))))
      	(set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity))
      				    (string-intersperse (map conc (verbosity)) ",")
      				    (conc (verbosity)))))))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
     	       (list?   verbosity)))
      (begin
     	(print "ERROR: Invalid debug value \"" vstr "\"")
     	#f)
      #t))

;;======================================================================
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))

	 (system (conc "mkdir -p " log-dir)))
     (open-output-file logpath))
   (exn ()
	(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath-in)
	(define *didsomething* #t)  
	(exit 1))))

(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
      		      (args:get-arg "-debug-noprop")
      		      (get-environment-variable "MT_DEBUG_MODE"))))
    (set! *verbosity* (debug:calc-verbosity debugstr 'q))
    (debug:check-verbosity *verbosity* debugstr)
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not *verbosity*)(set! *verbosity* 1))
    (if (and (not (args:get-arg "-debug-noprop"))
      	     (or (args:get-arg "-debug")
      		 (not (get-environment-variable "MT_DEBUG_MODE"))))
      	(set-environment-variable! "MT_DEBUG_MODE" (if (list? *verbosity*)
      				    (string-intersperse (map conc *verbosity*) ",")
      				    (conc *verbosity*))))))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
     	       (list?   verbosity)))
      (begin
     	(print "ERROR: Invalid debug value \"" vstr "\"")
     	#f)
      #t))

;; Disabled help items
;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;                            from prior runs with same keys
;;  -daemonize              : fork into background and disconnect from stdin/out

(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest