Megatest

(use extras)
(use data-structures)
(use srfi-1)
(use srfi-13)
(use regex)


(define (tests:get-test-property test-registry test property)
  (let loop ((rem-test-registry test-registry) (res #f))
    (if (null? rem-test-registry)
        res
        (let* ((this-test (car rem-test-registry))
              (this-testname (car this-test))
              (this-testrec (cdr this-test)))
          (if (eq? this-testname test)
              (alist-ref property this-testrec)
              (loop (cdr rem-test-registry) res))))))

(define (tests:get-test-waitons test-registry test)
  (tests:get-test-property test-registry test 'waitons))

(define (tests:get-test-items test-registry test)
  (or (tests:get-test-property test-registry test 'items) '()))

(define (tests:get-test-list test-registry)
  (map car test-registry))


(define (alist-push alist key val)
  (let ((current (alist-ref key alist)))
    (if current
        (alist-update key (cons val current) alist)
        (cons (list key val) alist))))

  
(define (test:get-adjacency-list test-registry)
  (let loop ((rem-tests (tests:get-test-list test-registry)) (res '()))
    (if (null? rem-tests)
        res
        (let* ((test (car rem-tests))
               (rest-rem-tests (cdr rem-tests))
               (waitons
                (or

(define (add-item-to-items-list item items)
  (cond
   ((eq? item '%) 
    (list '%))
   ((member '% items) 
    (list '%))
   ((member item items) 
    items)
   (else
    (cons item items))))

(define (append-items-lists l1 l2)
  (let loop ((rem-l1 l1) (res l2))
    (if (null? rem-l1)
        res
        (let* ((hed-rem-l1 (car rem-l1))
               (tal-rem-l1 (cdr rem-l1))
               (new-res (add-item-to-items-list hed-rem-l1 res)))
          (loop tal-rem-l1 new-res)))))

(define (sort-any inlist)
  (sort inlist (lambda (x y) (string<? (->string x) (->string y)))))

(define (condense-itemlist itemlist test test-registry)
  (let* ((test-items (tests:get-test-items test-registry test))
         (sorted-test-items (sort-any test-items))
         (sorted-itemlist (sort-any itemlist))
         (res
          (cond
           ((member '% itemlist )      '(%))
           ((equal? sorted-itemlist sorted-test-items)   '(%))
           (else
            (sort-any itemlist)))))
    ;;(print "condense-itemlist test-items="sorted-test-items" itemlist="sorted-itemlist"   res="res "   [equal?="(equal? sorted-test-items sorted-itemlist)"]")
    res))


; TODO : warning if itempatt matches no items in test in test registry
(define (condense-testpatt-alist-dummy alist test-registry) alist)
(define (condense-testpatt-alist alist test-registry)
  (let loop ((rest-alist alist) (res '()))
    (if (null? rest-alist)
        res
        (let* ((hed-alist (car rest-alist))
               (tal-alist (cdr rest-alist))
               (testname (car hed-alist))
               (incoming-items (cdr hed-alist))
               (existing-item-list (alist-ref testname res))
               (new-items-list
                (condense-itemlist
                 (if existing-item-list
                     (append-items-lists incoming-items existing-item-list)
                     incoming-items)
                 testname
                 test-registry))
               (new-res (alist-update testname new-items-list res)))
          (loop tal-alist new-res)))))
               

; TODO : warning if itempatt matches no items in test in test registry
(define (testpatt:alist->string testpatt-alist test-registry)
  (string-join
   (let loop ((rem-alist testpatt-alist) (res '()))
     (if (null? rem-alist)
        res
        (let* ((hed-alist (car rem-alist))
               (tal-alist (cdr rem-alist))
               (testname (car hed-alist))
               (item-patts (cdr hed-alist))
               (test-patts
                (map
                 (lambda (item)
                   (conc (->string testname) "/" (->string item)))
                 item-patts))
               (this-res (string-join test-patts ","))
               (new-res (cons this-res res)))
          ;;(print "bb: test-patts="test-patts" this-res="this-res" res="res" new-res="new-res)
          (loop tal-alist new-res))))
   ","))
                            
                         

               
          
  
(define (testpatt:string->alist testpatt test-registry)
  (if (string? testpatt)
      (let ((patts (string-split testpatt ",")))
        (if (null? patts) ;;; no pattern(s) means no match
            #f
            (let loop ((rest-patts patts) (res  '()))
              ;; (print "loop: patt: " patt ", tal " tal)
              (if (null? rest-patts)
                  (condense-testpatt-alist res test-registry)
                  (let* ((hed-patt (car rest-patts))
                         (tal-rest-patts (cdr rest-patts))
                         (patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") hed-patt))
                         (test (string->symbol (cadr patt-parts)))
                         (item-patt-raw  (cadddr patt-parts))
                         (item-patt
                          (if item-patt-raw
                              (string->symbol item-patt-raw)
                              '%))
                         (existing-item-patts (or (alist-ref test res) '()))
                         (new-item-patts (add-item-to-items-list item-patt existing-item-patts))
                         (new-res (alist-update test new-item-patts res)))
                    ;(print "BB->: test="test" item-patt-raw="item-patt-raw" item-patt="item-patt" existing-item-patts="existing-item-patts" new-item-patts="new-item-patts)
                    (loop tal-rest-patts new-res))))))))

(define (traverse node adjacency-list path)
  ;(print "node="node" path="path)
  (let ((children (alist-ref node adjacency-list)))
    (cond
     ((not children)  (list (cons node path)))
     (else
      (apply append
             (map
              (lambda (child)
                (traverse child adjacency-list (cons node path)))
              children))))))























































(define (get-waiton-items parent-test parent-item-patterns waiton-test test-registry)
  (let* ((parent-item->waiton-item (lambda (x) x)) ;; super simplified vs. megatest, should use itemmap property
         (waiton-test-items (or (tests:get-test-property test-registry waiton-test 'items) '(%)))
         )
    (let loop ((rest-parent-item-patterns parent-item-patterns) (res '()))
      (if (null? rest-parent-item-patterns)
          res
          (let* ((hed-parent-item (car rest-parent-item-patterns))
                 (tal-parent-items (cdr rest-parent-item-patterns))
                 (newres (add-item-to-items-list (parent-item->waiton-item hed-parent-item) res)))
            (loop tal-parent-items newres))))))

;; TODO: only do this with itemwait set true, not always
(define (push-itempatt-down-path waiton-path seed-items test-registry )
  (let loop ((rest-path waiton-path) (waiton-items seed-items) (res '())  )
    (if (null? rest-path)
        res
        (let* ((hed-test (car rest-path))
               (tal-path (cdr rest-path))
               (waiton-test (car rest-path))
               (waiton-items (get-waiton-items hed-test waiton-items waiton-test test-registry))
               (new-res (cons (cons waiton-test waiton-items) res)))
                 
          (loop tal-path waiton-items new-res)))))
               


(define (sort-testpatt-alist-topologically testpatt-alist toposorted-testlist)
  (let loop ((rem-testlist toposorted-testlist) (res '()))
    (if (null? rem-testlist)

        res   ;; TODO - handle if alist has testsnot in toposort-list
        (let* ((hed-test (car rem-testlist))
               (tal-testlist (cdr rem-testlist))


               (next-res (cons hed-test (alist-ref hed-test testpatt-alist)))





               (new-res (cons next-res res)))
          ;;(print "bb stat - hed-test="hed-test" next-res="next-res)
          (loop tal-testlist new-res)))))
               
  

(define (get-elaborated-testpatt-alist waiton-paths seed-testpatt-alist test-registry toposorted-testlist)
  (let ((raw-res
         (let loop ((rest-waiton-paths waiton-paths) (res '()))
           (if (null? rest-waiton-paths)
               res
               (let* ((hed-path (car rest-waiton-paths))
                      (tal-paths (cdr rest-waiton-paths))
                      (test (car hed-path))
                      (items (alist-ref test seed-testpatt-alist))
                      (new-res (cons (push-itempatt-down-path hed-path items test-registry) res))
                      
                      
                      )
                 (loop tal-paths new-res))))))
    (sort-testpatt-alist-topologically (condense-testpatt-alist (apply append raw-res) test-registry) toposorted-testlist)))


(define (get-elaborated-testpatt seed-testpatt test-registry)
  (let* ((adjacency-list (test:get-adjacency-list test-registry))
         (toposorted-testlist (topological-sort adjacency-list eq?))
         (seed-testpatt-alist (testpatt:string->alist seed-testpatt test-registry))
         (seed-tests (map car seed-testpatt-alist))
         (waiton-paths
          (map reverse
               (apply append
                      (map
                       (lambda (test)
                         (traverse test adjacency-list '())) seed-tests))))
         (final-testpatt-alist
          (get-elaborated-testpatt-alist
           waiton-paths
           seed-testpatt-alist
           test-registry
           toposorted-testlist))
         (final-testpatt-string (testpatt:alist->string final-testpatt-alist test-registry)))
    final-testpatt-string))




;; (set! test-registry2
;;       (cons
;;        (cons 'ALL-TESTS (list (cons 'waitons (tests:get-test-list test-registry))))
;;        test-registry))

(define test-registry
  '(
    (aa . ( (items . ( i1 i2 i3 )) ))
    (a  . ( (items . ( i1 i2 i3 )) ))
    (b  . ( (items . ( i1 i2 i3 ))
           (waitons . (a)   ) ) )
    (c  . ( (items . ( i1 i2 i3 ))
           (waitons . (a)   ) ) )
    (f  . ( (items . ( i1 i2 i3 ))
           (waitons . (a)   ) ) )
    (d  . ( (items . ( i1 i2 i3 ))
           (waitons . (b c) ) ) )
    (g  . ( (items . ( i1 i2 i3 ))
           (waitons . (b)   ) ) )
    (e  . ( (items . ( i1 i2 i3 ))
           (waitons . (d)   ) ) )
    (h  . ( (items . ( i1 i2 i3 ))
           (waitons . (d)   ) ) )
       ))

(define seed-testpatt "a/i1,a/i3,d,aa/%")

(define elaborated-testpatt (get-elaborated-testpatt seed-testpatt test-registry))
(print "test-registry:       ")
(pretty-print test-registry)

(print "\nseed-testpatt       = "seed-testpatt)
(print "\nelaborated-testpatt = "elaborated-testpatt)