Megatest

Artifact [d2739ff496]
Login

Artifact d2739ff496e470502b8c0ca44498c1301ebfedc8:



(use extras)
(use data-structures)
(use srfi-1)
(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-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-adj-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
                 (tests:get-test-waitons test-registry test)
                 '())))
          (loop rest-rem-tests
                (let loop2 ((rem-waitons waitons) (res2 res))
                  (if (null? rem-waitons)
                      res2
                      (let* ((waiton (car rem-waitons))
                             (rest-waitons (cdr rem-waitons))
                             (next-res (alist-push res2 waiton test)))
                        (loop2 rest-waitons next-res)))))))))



(define (add-item-to-items-list item items)
  (cond
   ((eq? item '%) 
    (list '%))
   ((member '% items) (print "% in 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 (testpatt->alist testpatt)
  (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)
                  res
                  (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 adj-list path)
  ;(print "node="node" path="path)
  (let ((children (alist-ref node adj-list)))
    (cond
     ((not children)  (list (cons node path)))
     (else
      (apply append
             (map
              (lambda (child)
                (traverse child adj-list (cons node path)))
              children))))))

(define test-registry
  '(
    (aa . ( (items . ( 1 2 3 )) ))
    (a  . ( (items . ( 1 2 3 )) ))
    (b  . ( (items . ( 1 2 3 ))
           (waitons . (a)   ) ) )
    (c  . ( (items . ( 1 2 3 ))
           (waitons . (a)   ) ) )
    (f  . ( (items . ( 1 2 3 ))
           (waitons . (a)   ) ) )
    (d  . ( (items . ( 1 2 3 ))
           (waitons . (b c) ) ) )
    (g  . ( (items . ( 1 2 3 ))
           (waitons . (b)   ) ) )
    (e  . ( (items . ( 1 2 3 ))
           (waitons . (d)   ) ) )
    (h  . ( (items . ( 1 2 3 ))
           (waitons . (d)   ) ) )
       ))

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



(pretty-print test-registry)
(define adj-list (test:get-adj-list test-registry))

(print "adjacency list=")(pretty-print adj-list)

(print "topological-sort=" (topological-sort adj-list eq?))

(define seed-testpatt "a/1,a/2,d,aa/%")
(define seed-testpatt-alist (testpatt->alist seed-testpatt))

;;(define seed-tests '(d aa))
(define seed-tests (map car seed-testpatt-alist))
(print "seed-testpatt="seed-testpatt"\n** seed-testpatt-alist="seed-testpatt-alist"\n seed-tests="seed-tests)

(define waiton-paths
  (map
   reverse
   (apply append
          (map
           (lambda (test)
             (traverse test adj-list '())) seed-tests))))
       

(print "waiton-paths=")
(pretty-print waiton-paths)  


(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))))))
   
(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)))))
               
(print "testpatts from first path="(car waiton-paths))

(define (condense-alist alist)
  (let loop ((rest-alist alist) (res '()))
    (if (null? rest-alist)
        res
        (let* ((hed-alist (car rest-alist))
               (tal-alist (cdr rest-alist))
               (key (car hed-alist))
               (new-items (cdr hed-alist))
               (existing-list (alist-ref key res))
               (new-list
                (if existing-list
                    (append-items-lists new-items existing-list)
                    new-items
                    ))
               (new-res (alist-update key new-list res)))
          (loop tal-alist new-res)))))
               
                    

(define (get-elaborated-testpatt-alist waiton-paths seed-testpatt-alist test-registry)
  (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))))))
    (condense-alist raw-res)))
        


(pretty-print
 (get-elaborated-testpatt-alist waiton-paths seed-testpatt-alist test-registry))