Megatest

(declare (uses treemod))

(use srfi-1
     posix regex regex-case srfi-69 typed-records sparse-vectors
     format
     extras
     (prefix iup iup:)
     canvas-draw
     sqlite3)

(import canvas-draw-iup)

(module ndboard
    *

(import scheme
	chicken
	data-structures
	extras
	format
	(prefix iup iup:)
	canvas-draw
	canvas-draw-iup
	matchable
	srfi-1 posix regex regex-case
	srfi-69 typed-records sparse-vectors ;; defstruct
	sqlite3
	
	treemod
	(prefix mtargs args:)
	)


(include "megatest-version.scm")

(define *areas* (make-hash-table))
(defstruct area
  path
  keys
  targets
  targets-update-time
  (dbhs (make-hash-table))
  )

(define (area-get-path area-name)
  (let* ((adat (get-area-info area-name)))
    (if adat
	(area-path adat)
	#f)))

(define (get-areas-file)
  (conc (get-environment-variable "HOME")"/.ndboard/areas.scm"))

(define (get-areas)
  (let* ((areas-file (get-areas-file)))
    (if (file-exists? areas-file)
	(with-input-from-file areas-file read))))

(define (register-area areadat)
  (hash-table-set! *areas* (car areadat)
		   (make-area path: (cdr areadat))))

(define (get-area-info area-name)
  (hash-table-ref/default *areas* area-name #f))

(define (area-save-dbh area-name dbname mtdbh)
  (hash-table-set! (area-dbhs (get-area-info area-name)) dbname mtdbh))

(define (area-get-dbh area-name dbname)
  (hash-table-ref/default (area-dbhs (get-area-info area-name)) dbname #f))

;; megatest calls, run in "area"
;;

;; TODO store the last time the query was run
;; and clear cache based on timestamp on main.db
;;
(define (megatest-get-targets area-name)

(define (megatest-get-keys area-name)
  (let* ((ainfo   (get-area-info area-name))
	 (keys    (area-keys ainfo)))
    (if keys
	keys
	(let* ((path     (area-path ainfo))
	       (keysstr (with-input-from-pipe
			    (conc "megatest -show-keys -start-dir "path)
			  read-line)))
	  (if (not (string? keysstr))
	      (print "Unknown error getting keys for area "area-name", path: "path)

	      (let* ((keys   (string-split keysstr)))
		(area-keys-set! ainfo keys)
		keys))))))

;; megatest area database access functions
;;

(defstruct mtdb
  name
  db
  path)

;; dbname is main.db, 1.db ...
(define (megatest-open-db area-name dbname)
  (let* ((mtdbh (area-get-dbh area-name dbname)))
    (if mtdbh
	mtdbh
	(let* ((ainfo    (get-area-info area-name))
	       (path     (area-path ainfo))
	       (dbpath   (conc path"/.megatest/"dbname))
	       (dbexists (and (file-exists? dbpath)
			      (file-read-access? dbpath))))
	  (if dbexists
	      (let* ((db (open-database dbpath)))
		(set-busy-handler! db (make-busy-timeout 136000))
		(execute db "PRAGMA synchronous = 0;")
		(let* ((mtdbh (make-mtdb db: db path: dbpath)))
		  (area-save-dbh area-name dbname mtdbh)
		  mtdbh))
	      #f)))))

;; ADD on-exit to close the opened dbs

;; keys is list, targpatts is list, both same length
;; and *fully* specified
;; returns targvals and runname
(define (megatest-get-run-names area-name keys targpatts)
  (let* ((mtdbh    (megatest-open-db area-name "main.db"))
	 (selector (string-intersperse
		    (map (lambda (k v)(conc k" like '"v"'")) keys targpatts)
		    " AND "))
	 (field-sel (string-intersperse keys ","))
	 (fullqry   (conc "SELECT "field-sel",runname FROM runs WHERE "selector";")))
    (print "fullqry="fullqry)
    (fold-row ;; proc init db-or-stmt . params)
     (lambda (res . row)
       (cons row res))
     '()
     (mtdb-db mtdbh) ;; get the db handle
     fullqry)))
     


;; gui utils
;;

(define (message-window msg)
  (iup:show
   (iup:dialog
    (iup:vbox 

   #:size "10x"
   #:selection-cb
   (lambda (obj id state)
     (let* ((path (tree:node->path obj id)))
       (match path
	 ((treename) #f) ;;(print "nothing to do here"))
	 ((treename area)
	  (let ((tb (get-widget "main-tree"))) ;; wait, isn't this just "obj"?
	    (refresh-targets tb area)))
	 ((treename area . target)
	  (let* ((keys (megatest-get-keys area)))
	    (if (eq? (length keys)(length target))
		(let* ((runnames (megatest-get-run-names area keys target)))
		  (for-each
		   (lambda (runnamedat)
		     (tree:add-node obj "Areas" (cons area runnamedat)))
		   runnames)))))
	 (else
	  (print "path: "path))
	  )
       #;(print "obj: "obj", id: "id", state: "state", path: "path)))))

(define (refresh-targets tb area)
  (let* ((targets (megatest-get-targets area)))