Megatest

;;              of tests to run. The item portions are not respected.
;;              FIXME: error out if /patt specified
;;            
(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names
  (let* ((keys               (keys:config-get-fields *configdat*))
	 (keyvals            (keys:target->keyval keys target))
	 (run-id             (rmt:register-run keyvals runname "new" "n/a" user))  ;;  test-name)))
	 (deferred          '()) ;; delay running these since they have a waiton clause (never used - BB)
	 (runconfigf         (conc  *toppath* "/runconfigs.config"))
	 (test-records       (make-hash-table))
	 ;; need to process runconfigs before generating these lists
	 (all-tests-registry #f)  ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names
	 (all-test-names     #f)  ;; (hash-table-keys all-tests-registry))
	 (test-names         #f)  ;; (tests:filter-test-names all-test-names test-patts))
	 (required-tests     #f)  ;; Put fully qualified test/testpath names in this list to be done
	 (task-key           (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
	 (tdbdat             (tasks:open-db))
	 (config-reruns      (let ((x (configf:lookup *configdat* "setup" "reruns")))
			       (if x (string->number x) #f))))
    (debug:print-info 0 "BB------------------------------------------------\nBB: entered run:run-tests with target="target" runname="runname" test-patts="test-patts" user="user" flags="flags" run-count="run-count)
    ;; override the number of reruns from the configs
    (if (and config-reruns
	     (> run-count config-reruns))
	(set! run-count config-reruns))
    
    (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10))

    ;; refactoring this block into tests:get-full-data
    ;;
    ;; What happended, this code is now duplicated in tests!?
    ;;
    ;;======================================================================
    
    (if (not (null? test-names))
	(let loop ((processed '())
                   (hed (car test-names))
		   (tal (cdr test-names)))         ;; 'return-procs tells the config reader to prep running system but return a proc
          (debug:print-info 0 "BB: +++LOOP (iter="(counter 'rtloop)")  test-patts="test-patts" hed="hed" tal="tal)
	  (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
	  (setenv "MT_TEST_NAME" hed) ;; 
	  (let*-values (((waitons waitors config)(tests:get-waitons hed all-tests-registry)))
	    (debug:print-info 8 "waitons: " waitons)
	    ;; check for hed in waitons => this would be circular, remove it and issue an
	    ;; error
	    (if (or (member hed waitons)
		    (member hed waitors))
		(begin
		  (debug:print 0 "ERROR: test " hed " has listed itself as a waiton or waitor, please correct this!")
		  (set! waitons (filter (lambda (x)(not (equal? x hed))) waitons))
		  (set! waitors (filter (lambda (x)(not (equal? x hed))) waitors))))
	    
	    ;; (items   (items:get-items-from-config config)))
	    (if (not (hash-table-ref/default test-records hed #f))
		(begin
                  (debug:print-info 0 "BB: HASH ADD "hed" whose waitors are >"waitors"<")
                  (hash-table-set! test-records  ;; BB: here we add record to hash table
				 hed (vector hed     ;; 0
					     config  ;; 1
					     waitons ;; 2
					     (config-lookup config "requirements" "priority")     ;; priority 3
					     (let ((items      (hash-table-ref/default config "items" #f)) ;; items 4
						   (itemstable (hash-table-ref/default config "itemstable" #f))) 
					       ;; if either items or items table is a proc return it so test running
					       ;; process can know to call items:get-items-from-config
					       ;; if either is a list and none is a proc go ahead and call get-items
					       ;; otherwise return #f - this is not an iterated test
					       (cond
						((procedure? items)      
						 (debug:print-info 4 "items is a procedure, will calc later") ;; BB? calc later? when?? why not now?
						 items)            ;; calc later
						((procedure? itemstable)
						 (debug:print-info 4 "itemstable is a procedure, will calc later")
						 itemstable)       ;; calc later
						((filter (lambda (x)
							   (let ((val (car x)))
							     (if (procedure? val) val #f)))
							 (append (if (list? items) items '())
								 (if (list? itemstable) itemstable '())))
						 'have-procedure)
						((or (list? items)(list? itemstable)) ;; calc now
						 (debug:print-info 4 "items and itemstable are lists, calc now\n"
								   "    items: " items " itemstable: " itemstable)
						 (items:get-items-from-config config))
						(else #f)))                           ;; not iterated
					     #f      ;; itemsdat 5
					     #f      ;; spare - used for item-path
					     waitors ;; 
					     ))))
            (debug:print-info 0 "BB: iterating over waitons+waitors -> waitons="waitons" waitors="waitors)
	    (for-each 
	     (lambda (waiton)
               (debug:print-info 0 "BB:   - visiting "waiton)
	       (if (and waiton (not (member waiton test-names)))
		   (let* ((waiton-record   (hash-table-ref/default test-records waiton #f))
			  (waiton-tconfig  (if waiton-record (vector-ref waiton-record 1) #f))
			  (waiton-itemized (and waiton-tconfig
						(or (hash-table-ref/default waiton-tconfig "items" #f)
						    (hash-table-ref/default waiton-tconfig "itemstable" #f))))
			  (itemmaps        (tests:get-itemmaps config));; (configf:lookup config "requirements" "itemmap"))
			  (new-test-patts  (tests:extend-test-patts test-patts hed waiton itemmaps)))
                     (debug:print-info 0 "BB: HASH REF "waiton" (waiton)")
		     (debug:print-info 0 "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items")
		     ;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%"
		     ;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt
		     ;; is this satisfied by merely appending "/" to the waiton name added to the list?
		     ;;
		     ;; This approach causes all of the items in an upstream test to be run 

		     ;; if we have this waiton already processed once we can analzye it for extending
		     ;; tests to be run, since we can't properly process waitons unless they have been
		     ;; initially added we add them again to be processed on second round AND add the hed
		     ;; back in to also be processed on second round
		     ;;
		     (if waiton-tconfig ;; will be false if waiton record has not been added to hash yet
			 (begin

			   (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read
			   (if waiton-itemized
			       (begin
				 (debug:print-info 0 "New test patts: " new-test-patts ", prev test patts: " test-patts)
				 (set! required-tests (cons (conc waiton "/") required-tests))
                                 (debug:print-info 0 "!!! BB !!! waiton *is* itemized accepted new-test-patts->test-patts: "new-test-patts)
				 (set! test-patts new-test-patts)
                                 (set! processed (cons hed processed))
                                 )
			       (begin
				 (debug:print-info 0 "Adding non-itemized test " waiton " to required-tests")
				 (set! required-tests (cons waiton required-tests))
                                 (debug:print-info 0 "!!! BB !!! waiton NOT itemized accepted new-test-patts->test-patts: "new-test-patts)
				 (set! test-patts new-test-patts)
                                 (set! processed (cons hed processed))
                                 )))
			 (begin
			   (debug:print-info 0 "No testconfig info yet for " waiton ", setting up to re-process it even though new-test-patt is >"new-test-patts"<")

                           ;; BB: by pushing upstream test with item
                           ;; filter to end, downstream tests' items
                           ;; are not filtered when encountered.  This
                           ;; causes chained-waiton/item_seq4 to FAIL.
                           ;; when test3/%, test2/%, test1/% all items
                           ;; are added to testpatt when instead
                           ;; test4/item.1 should imply test3/item.1,
                           ;; which shold imply test2/item.1 and so on
                           (debug:print-info 0 "BB: pushing "hed" to back of the line")
                           (debug:print-info 0 "BB: new tal = waiton,tal + hed = "waiton","tal" + "hed)
                           
                           (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests)) ;; BB- EXAMINE
                     
		     ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts
		     ;;  - doesn't work
		     ;; (set! test-patts (conc test-patts "," waiton "/"))
		     
		     ;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
		     ))
               (debug:print-info 0 "BB:   - leaving "waiton)
               )
	     (delete-duplicates (append waitons waitors)))
            (debug:print-info 0 "BB: done iterating over waitons+waitors -> waitons="waitons" waitors="waitors)
	    (let ((remtests (delete-duplicates (append waitons tal)))) ;; BB EXAMINE
	      (if (not (null? remtests))
		  (begin 
                    
		    (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", "))
                    ;; BB: remtest must be in topological order of waiton edges
                    (let* (
                           (filtered-remtests (filter (lambda (x) (not (member x processed))) remtests))
                           (new-hed (car filtered-remtests))
                           (method (string->symbol (or (get-environment-variable "DEPSORTMETHOD") "new"))) ;; setenv DEPSORTMETHOD old to go back
                           (new-tal
                            (if (eq? method 'old)
                                (cdr filtered-remtests)
                                (runs:toposort (cdr filtered-remtests) all-tests-registry))))
                      ;;(set! remtests (runs:toposort remtests all-tests-registry))
                      ;;(loop (car remtests)(cdr remtests))
                      (loop processed new-hed new-tal)
                    )))))))


    
    (counter-reset 'rtloop)
    (debug:print-info 0 "BB: Finished elaboration of waiton dependencies (maybe?)")
    (if (not (null? required-tests))
	(debug:print-info 0 "BB Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) ; BB changed 1 to 0
    ;; NOTE: these are all parent tests, items are not expanded yet.
    (debug:print-info 0 "BB test-records=" (hash-table->alist test-records)) ; BB: changed 4 to 0
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (let* ((keep-going        #t)

		  ;; recursive call to self
		  (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))))
	  (debug:print-info 0 "No tests to run")))
    (debug:print-info 4 "All done by here")
    (rmt:tasks-set-state-given-param-key task-key "done")
    ;; (sqlite3:finalize! tasks-db)
    ))

;; define custom counters -- very handy to line up iteration of debug message calls within a single execution
(define *counter-alist* (make-parameter '()))
(define (counter key)
  (let* ((counter-param
         (or
          (alist-ref (->string key) (*counter-alist*) equal?)
          (let ((new-counter (make-parameter 0)))
            (*counter-alist* (cons (cons (->string key) new-counter) (*counter-alist*)))
            new-counter)))
         (current-count (counter-param))
         (new-count (add1 current-count)))
    (counter-param new-count)))

(define (counter-reset key)
  (let ((existing-counter (alist-ref (->string key) (*counter-alist*) equal?)))
    (if existing-counter
        (existing-counter 0)
        (counter key))))
        
          
;; BAD HACK follows.
;; on initial pass thru, adjacency-list is correct.  later, somehow waitons get corrupted (eg. EVERYTHING depends on test3.. whY?
;; the hack - cache initial adjacency-list  (hopefully alltests cannot change midstream or the static analysis is otherwise invalidated!!)
;; good god, *cached-adjacency-list* changes over time.  Should be constant! wtf?, disabling cache.


(define *cached-adjacency-list* (make-parameter #f))

;; (define (runs:get-itemmaps all-tests-registry)
;;   (let* ((full-adjacency-list
;;          (map
;;           (lambda (test)
;;             (let*-values (((waitons waitors config) (tests:get-waitons test all-tests-registry)))
;;               (debug:print-info 0 "    BB: test="test" waitons="waitons" waitors="waitors)
;;               (cons test (append waitons waitors))))))))

;; ;(hash-table-ref all-tests-registry test-name))
  
;;   )
  

(define (runs:get-test-adjacency-list all-tests-registry testlist-filter )
  ;; on first pass, initialize cache with adjacency-list for all tests 
  (when (or #t (not (*cached-adjacency-list*))) ;; or #t forces eval every time
      (let* ((alltestlist (hash-table-keys (tests:get-all)))
             (full-adjacency-list
                (map
                 (lambda (test)
                   (let*-values (((waitons waitors config) (tests:get-waitons test all-tests-registry)))
                     (debug:print-info 0 "    BB: test="test" waitons="waitons" waitors="waitors)
                     (cons test (append waitons waitors))))
                 ;;testlist-filter))
                 alltestlist))
             (sorted-alltestlist (sort alltestlist (lambda (a b) (string< (->string a) (->string b))))))
        (debug:print-info 0 "--=> BB: ALLTESTLIST iter="(counter 'alltestlist)"  val="sorted-alltestlist)

        (debug:print-info 0 "--=> BB: initialized *cached-adjacency-list* with "
                          full-adjacency-list)
        (*cached-adjacency-list* full-adjacency-list)))

  ;; return adjacency-list only containing tests in testlist-filter
  (let* ((full-adjacency-list (*cached-adjacency-list*))
         ;; trim list - 1) remove any toplevel list whose car is not a member of testlist-filter
         ;;             2) remove all items from cdr which is not a member of testlist-filter
         ;;             3) shouldn't happen, but remove any from cdr which matches car
         (trimmed-list-1 (filter
                          (lambda (row)
                            (member (car row) testlist-filter))
                          full-adjacency-list))
         (trimmed-list-2 (map
                          (lambda (row)
                            (filter
                             (lambda (field)
                               (member field testlist-filter))
                             row))
                          trimmed-list-1))
         (trimmed-list-3 (map
                          (lambda (row)
                            (let ((hed (car row)) (tal (cdr row)))
                              (cons hed
                                    (filter
                                     (lambda (field)
                                       (not (equal? field hed)))
                                     tal))))
                          trimmed-list-2))
         (adjacency-list trimmed-list-3))
    (debug:print-info 0 "      BB full-adjacency-list="full-adjacency-list)
    (debug:print-info 0 "      BB trimmed-list-1"trimmed-list-1)
    (debug:print-info 0 "      BB trimmed-list-2"trimmed-list-2)
    (debug:print-info 0 "      BB trimmed-list-3"trimmed-list-3)
    (debug:print-info 0 "     BB entered with testlist-filter="testlist-filter)
    adjacency-list))
        

(define (toposort-check testlist sortedlist)
  (let* ((normalize-list (lambda (the-list) (sort the-list (lambda (a b) (string< (->string a) (->string b))))))
         (normal-testlist (normalize-list testlist))
         (normal-sortedlist (normalize-list sortedlist))
         (OK  (cond
               ((not (= (length normal-testlist) (length normal-sortedlist)))
                (debug:print-info 0 "BB: TOPOSORT-CHECK FAILED.  length["testlist"] != length["sortedlist"]")
                #f)
               ((not (equal? normal-testlist normal-sortedlist))
                (debug:print-info 0 "BB: TOPOSORT-CHECK FAILED.  members["testlist"] != members["sortedlist"]")
                #f)
               (else
               (debug:print-info 0 "BB: TOPOSORT-CHECK :) PASS :)")))))

    
    OK))
    
          
(define (runs:toposort testlist all-tests-registry)
  ;(print "ALL-TESTS-REGISTRY")
  
  ;(pretty-print (hash-table->alist all-tests-registry))
  ;(exit 1)
    

  (let* ((adjacency-list (runs:get-test-adjacency-list all-tests-registry testlist)))
    (debug:print-info 0 "BB> adjacency-list("testlist") = "adjacency-list)
    (let ((sorted-list
           (topological-sort adjacency-list equal?)))
      (debug:print-info 0 "BB> sorted-list("testlist") = "sorted-list)
      (let* ((filtered-sorted-list
             (filter (lambda (item) (member item testlist)) sorted-list))
             (res filtered-sorted-list))
        (debug:print-info 0 "BB> TOPOSORT-*"(counter res)"*-       "testlist" ==**==> " filtered-sorted-list)
        (toposort-check testlist res)
        res
        ))))


;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns
;; If reg is full (i.e. length >= n
;;   loop with (car reg) tal (cdr reg) reruns