Megatest

;; (define old-exit exit)
;; 
;; (define (exit . code)
;;   (if (null? code)
;;       (old-exit)
;;       (old-exit code)))

(define (common:debug-setup)
  (debug:setup (cond ;; debug arg
		((args:get-arg "-debug-noprop") 'noprop)
		((args:get-arg "-debug")         #t)
		(else #f))
	       (cond ;; verbosity arg
		((args:get-arg "-q") 'v)
		((args:get-arg "-q") 'q)
		(else #f))))

;; execute thunk, return value.  If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* .
;; arguments - thunk, message
(define (common:fail-safe thunk warning-message-on-exception)
  (handle-exceptions
   exn
   (begin

   ((and (list? vb)     ;; list   list
	 (list? n))
    (not (null? (lset-intersection! eq? vb n))))
   ((and (number? vb)
	 (list? n))
    (member vb n)))))

(define (debug:setup debug-arg verbose-arg) ;; debug-arg= #f, #t or 'noprop
  (let ((debugstr (or debug-arg ;; (args:get-arg "-debug")
		      ;; (args:get-arg "-debug-noprop")
		      (get-environment-variable "MT_DEBUG_MODE"))))
    (debug:calc-verbosity debugstr verbose-arg)
    ;; (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 (eq? debug-arg 'noprop))
	     (or debug-arg
		 (not (get-environment-variable "MT_DEBUG_MODE"))))
	(setenv "MT_DEBUG_MODE" (if (list? (verbosity))

;;======================================================================

(use regex regex-case matchable) ;;  directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))

(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))

(import commonmod)

(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")
(include "vg_records.scm")

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

  ;; runs summary view
  
  tests-tree       ;; used in newdashboard
  )

;; 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:
;;                  (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:tabdat-target-string vec)
  (let ((targ (dboard:tabdat-target vec)))
    (if (list? targ)(string-intersperse targ "/") "no-target-specified")))

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




(define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began
  (make-dboard:rundat 
   run: run

    (if t-sort
	(cadr t-sort)
	3)))

(define (get-curr-sort)
  (vector-ref *tests-sort-options* *tests-sort-reverse*))

(common:debug-setup)

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

(import canvas-draw-iup)
(use regex typed-records matchable)

(declare (unit dcommon))

(declare (uses gutils))
(declare (uses db))

(declare (uses commonmod))
(import commonmod)

;; (declare (uses synchash))

(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

		   (exit 1))))
	   homehost-required))))

;;======================================================================
;; Misc setup stuff
;;======================================================================

(common:debug-setup)




;; (if (args:get-arg "-logging")(set! *logging* #t))

;;(if (debug:debug-mode 3) ;; we are obviously debugging
;;    (set! open-run-close open-run-close-no-exception-handling))

(if (args:get-arg "-itempatt")

;;======================================================================

(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))

(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
;; (declare (uses rmtmod))

;; (import rmtmod)

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!