From 6cf37f82b7c4dc77655b5d24298905860e02901f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 4 Jul 2014 04:52:13 +0100
Subject: [PATCH] meta/pkg-build: handle dependency cycles

---
 pkgs/plt-services/info.rkt                    |   3 +-
 pkgs/plt-services/meta/pkg-build/main.rkt     | 116 ++++++++++++------
 .../meta/pkg-build/union-find.rkt             |  64 ++++++++++
 3 files changed, 145 insertions(+), 38 deletions(-)
 create mode 100644 pkgs/plt-services/meta/pkg-build/union-find.rkt

diff --git a/pkgs/plt-services/info.rkt b/pkgs/plt-services/info.rkt
index 00166a4dad..648f199505 100644
--- a/pkgs/plt-services/info.rkt
+++ b/pkgs/plt-services/info.rkt
@@ -26,7 +26,8 @@
                "scribble-lib"
                "compatibility-lib"
                "plt-web"
-               "web-server-lib"))
+               "web-server-lib"
+               "rackunit-lib"))
 
 (define pkg-desc "Miscellaneous management and maintenance tools used by the Racket development team")
 
diff --git a/pkgs/plt-services/meta/pkg-build/main.rkt b/pkgs/plt-services/meta/pkg-build/main.rkt
index a2efa0f7d0..9a20be8902 100644
--- a/pkgs/plt-services/meta/pkg-build/main.rkt
+++ b/pkgs/plt-services/meta/pkg-build/main.rkt
@@ -11,7 +11,8 @@
          net/url
          pkg/lib
          distro-build/vbox
-         web-server/servlet-env)
+         web-server/servlet-env
+         "union-find.rkt")
 
 (provide build-pkgs)
 
@@ -36,7 +37,6 @@
 ;;     needed by `racket/draw`)
 ;;
 ;; FIXME:
-;;  - handle dependency cycles
 ;;  - handle conflicting doc names
 ;;  - check that declared dependencies are right
 ;;  - keep docs that build despite errors
@@ -160,7 +160,19 @@
     (printf ">> ")
     (apply substatus fmt args))
 
-  (define (show-list strs)
+  (define (show-list nested-strs)
+    (define strs (let loop ([strs nested-strs])
+                   (cond
+                    [(null? strs) null]
+                    [(pair? (car strs))
+                     (define l (car strs))
+                     (define len (length l))
+                     (loop (append
+                            (list (string-append "(" (car l)))
+                            (take (cdr l) (- len 2))
+                            (list (string-append (last l) ")"))
+                            (cdr strs)))]
+                    [else (cons (car strs) (loop (cdr strs)))])))
     (substatus "~a\n"
                (for/fold ([a ""]) ([s (in-list strs)])
                  (if ((+ (string-length a) 1 (string-length s)) . > . 72)
@@ -477,31 +489,49 @@
   (define need-pkgs (set-subtract (set-subtract update-pkgs installed-pkgs)
                                   failed-pkgs))
 
-  ;; Sort needed packages based on dependencies:
-  (define need-pkgs-list 
-    (let loop ([l (sort (set->list need-pkgs) string<?)] [seen (set)] [cycle-seen (set)])
-      (cond
-       [(null? l) null]
-       [(set-member? cycle-seen (car l))
-        (eprintf "WARNING: cannot yet handle cycles reliably, discovered at: ~s\n" (car l))
-        (loop (cdr l) seen cycle-seen)]
-       [(set-member? seen (car l)) (loop (cdr l) seen cycle-seen)]
-       [else
-        (define pkg (car l))
-        (define new-seen (set-add seen pkg))
-        (define deps
-          (for/list ([dep (in-list (pkg-deps pkg))]
-                     #:unless (set-member? seen dep)
-                     #:when (set-member? need-pkgs dep))
-            dep))
-        (if (null? deps)
-            (cons pkg (loop (cdr l) new-seen cycle-seen))
-            (let ([pre (loop deps new-seen (set-add cycle-seen pkg))])
-              (append pre
-                      (cons pkg
-                            (loop (cdr l)
-                                  (set-union new-seen (list->set pre))
-                                  cycle-seen)))))])))
+  (define cycles (make-hash)) ; for union-find
+
+  ;; Sort needed packages based on dependencies, and accumulate cycles:
+  (define need-rep-pkgs-list
+    (let loop ([l (sort (set->list need-pkgs) string<?)] [seen (set)] [cycle-stack null])
+      (if (null? l)
+          null
+          (let ([pkg (car l)])
+            (cond
+             [(member pkg cycle-stack)
+              ;; Hit a package while processing its dependencies;
+              ;; everything up to that package on the stack is
+              ;; mutually dependent:
+              (for ([s (in-list (member pkg (reverse cycle-stack)))])
+                (union! cycles pkg s))
+              (loop (cdr l) seen cycle-stack)]
+             [(set-member? seen pkg)
+              (loop (cdr l) seen cycle-stack)]
+             [else
+              (define pkg (car l))
+              (define new-seen (set-add seen pkg))
+              (define deps
+                (for/list ([dep (in-list (pkg-deps pkg))]
+                           #:when (set-member? need-pkgs dep))
+                  dep))
+              (define pre (loop deps new-seen (cons pkg cycle-stack)))
+              (define pre-seen (set-union new-seen (list->set pre)))
+              (define remainder (loop (cdr l) pre-seen cycle-stack))
+              (elect! cycles pkg) ; in case of mutual dependency, follow all pre-reqs
+              (append pre (cons pkg remainder))])))))
+
+  ;; A list that contains strings and lists of strings, where a list
+  ;; of strings represents mutually dependent packages:
+  (define need-pkgs-list
+    (let ([reps (make-hash)])
+      (for ([pkg (in-set need-pkgs)])
+        (hash-update! reps (find! cycles pkg) (lambda (l) (cons pkg l)) null))
+      (for/list ([pkg (in-list need-rep-pkgs-list)]
+                 #:when (equal? pkg (find! cycles pkg)))
+        (define pkgs (hash-ref reps pkg))
+        (if (= 1 (length pkgs))
+            pkg
+            pkgs))))
 
   (substatus "Packages that we need:\n")
   (show-list need-pkgs-list)
@@ -592,19 +622,26 @@
 
   ;; Build one package or a group of packages:
   (define (build-pkgs pkgs)
+    (define flat-pkgs (flatten pkgs))
+    ;; one-pkg can be a list in the case of mutual dependencies:
     (define one-pkg (and (= 1 (length pkgs)) (car pkgs)))
-    (define pkgs-str (or one-pkg
-                         (apply ~a #:separator " " pkgs)))
+    (define pkgs-str (apply ~a #:separator " " flat-pkgs))
 
     (status (~a (make-string 40 #\=) "\n"))
     (if one-pkg
-        (status "Building ~a\n" one-pkg)
+        (if (pair? one-pkg)
+            (begin
+              (status "Building mutually dependent packages:\n")
+              (show-list one-pkg))
+            (status "Building ~a\n" one-pkg))
         (begin
           (status "Building packages together:\n")
           (show-list pkgs)))
 
     (define failure-dest (and one-pkg
-                              (pkg-failure-dest one-pkg)))
+                              (pkg-failure-dest (if (list? one-pkg)
+                                                    (car one-pkg)
+                                                    one-pkg))))
 
     (define (save-checksum pkg)
       (call-with-output-file*
@@ -637,7 +674,7 @@
                               (build-path work-dir "user-list.rktd")
                               read))
             (for/and ([pkg (in-list new-pkgs)])
-              (or (member pkg pkgs)
+              (or (member pkg flat-pkgs)
                   (set-member? installed-pkgs pkg)
                   (file-exists? (build-path built-catalog-dir "pkg" pkg))
                   (complain failure-dest
@@ -651,7 +688,7 @@
                " > ../pkg-docs.rktd"
                #:mode 'result
                #:failure-dest failure-dest)
-          (for/and ([pkg (in-list pkgs)])
+          (for/and ([pkg (in-list flat-pkgs)])
             (ssh cd-racket
                  " && bin/raco pkg create --from-install --built"
                  " --dest " vm-dir "/built"
@@ -660,7 +697,7 @@
                  #:failure-dest failure-dest))))
        (cond
         [ok?
-         (for ([pkg (in-list pkgs)])
+         (for ([pkg (in-list flat-pkgs)])
            (when (file-exists? (pkg-failure-dest pkg))
              (delete-file (pkg-failure-dest pkg)))
            (scp (at-vm (~a vm-dir "/built/" pkg ".zip"))
@@ -677,10 +714,14 @@
                   (fprintf o "success\n")
                   (fprintf o "success with ~s\n" pkgs))))
            (save-checksum pkg))
-         (update-built-catalog pkgs)]
+         (update-built-catalog flat-pkgs)]
         [else
          (when one-pkg
-           (save-checksum one-pkg))
+           (for ([pkg (in-list flat-pkgs)])
+             (when (list? one-pkg)
+               (unless (equal? pkg (car one-pkg))
+                 (copy-file failure-dest (pkg-failure-dest (car one-pkg)) #t)))
+             (save-checksum pkg)))
          (substatus "*** failed ***\n")])
        ok?)
      (lambda ()
@@ -690,6 +731,7 @@
   ;; groups if the whole group fails or is too
   ;; big:
   (define (build-all-pkgs pkgs)
+    ;; pkgs is a list of string and lists (for mutual dependency)
     (define len (length pkgs))
     (define ok? (and (len . <= . max-build-together)
                      (build-pkgs pkgs)))
diff --git a/pkgs/plt-services/meta/pkg-build/union-find.rkt b/pkgs/plt-services/meta/pkg-build/union-find.rkt
new file mode 100644
index 0000000000..db84485f86
--- /dev/null
+++ b/pkgs/plt-services/meta/pkg-build/union-find.rkt
@@ -0,0 +1,64 @@
+#lang racket/base
+
+(provide union! find! elect!)
+
+(define (find! reps key)
+  (define rep-key (hash-ref reps key key))
+  (if (equal? rep-key key)
+      key
+      (let ([rep-key (find! reps rep-key)])
+        (hash-set! reps key rep-key)
+        rep-key)))
+
+(define (elect! reps key)
+  (define rep-key (hash-ref reps key key))
+  (unless (equal? rep-key key)
+    (hash-set! reps rep-key key)
+    (hash-set! reps key key)))
+
+(define (union! reps a-key b-key)
+  (define rep-a-key (find! reps a-key))
+  (define rep-b-key (find! reps b-key))
+  (unless (equal? rep-a-key rep-b-key)
+    (hash-set! reps rep-b-key rep-a-key))
+  rep-a-key)
+
+(module+ test
+  (require rackunit)
+
+  (define t1 (make-hash))
+  (void
+   (union! t1 "1" "2")
+   (union! t1 "a" "b")
+   (union! t1 "b" "c")
+   (union! t1 "d" "e")
+   (union! t1 "f" "d")
+   (union! t1 "3" "2")
+   (union! t1 "g" "d")
+   (union! t1 "b" "d"))
+
+  (check-equal? (find! t1 "a") "a")
+  (check-equal? (find! t1 "b") "a")
+  (check-equal? (find! t1 "b") "a")
+  (check-equal? (find! t1 "d") "a")
+  (check-equal? (find! t1 "e") "a")
+  (check-equal? (find! t1 "f") "a")
+  (check-equal? (find! t1 "g") "a")
+
+  (elect! t1 "c")
+
+  (check-equal? (find! t1 "a") "c")
+  (check-equal? (find! t1 "b") "c")
+  (check-equal? (find! t1 "b") "c")
+  (check-equal? (find! t1 "d") "c")
+  (check-equal? (find! t1 "e") "c")
+  (check-equal? (find! t1 "f") "c")
+  (check-equal? (find! t1 "g") "c")
+
+  (check-equal? (find! t1 "1") "3")
+  (check-equal? (find! t1 "2") "3")
+  (check-equal? (find! t1 "3") "3"))
+
+
+  
+