cargoless-rust-experiments/topological-sort.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

;; To be used by the implementation of workspaces.
;; Extracted from (guix import utils), and changed from (guix sets)
;; to a guile-pfds equivalent.
(define-module (topological-sort)
  #:export (topological-sort topological-sort*)
  #:use-module (srfi srfi-1)
  #:use-module ((srfi srfi-69) #:select (hash))
  #:use-module ((ice-9 match) #:select (match))
  ;; XXX: Cuirass compiles even build-side only modules.
  #:autoload (pfds hamts) (make-hamt hamt-ref hamt-set))

(define (topological-sort nodes
                          node-dependencies
                          node-name)
  "Perform a breadth-first traversal of the graph rooted at NODES, a list of
nodes, and return the list of nodes sorted in topological order.  Call
NODE-DEPENDENCIES to obtain the dependencies of a node, and NODE-NAME to
obtain a node's uniquely identifying \"key\"."
  (define (node=? x y)
    (equal? (node-name x) (node-name y)))
  (define tag (make-prompt-tag 'topological-sort))
  (define (maybe-visit node recurse)
    (abort-to-prompt tag node recurse))
  (define (done)
    (abort-to-prompt tag))
  (define (visit-recursively node)
    (maybe-visit
     node
     (lambda ()
       (for-each visit-recursively (node-dependencies node)))))
  (define (initial-thunk)
    (for-each visit-recursively nodes)
    (done))
  (let loop ((continue initial-thunk)
	     (visiting '()) ; call stack, for detecting cycles
	     (visited '())) ; set represented as a list
    (call-with-prompt
     tag continue
     (case-lambda
      ((k) visited) ; done
      ((k node recurse)
       (cond ((member node visiting node=?)
	      (pk (cons node visiting))
	      (error "cycle detected"))
	     ((member node visited node=?)
	      ;; Nothing to do
	      (loop k visiting visited))
	     (#true
	      ;; Push it on the stack, recurse,
	      ;; then continue (without having it on the stack).
	      (loop k
		    visiting
		    (cons node
			  (loop (lambda ()
				  (recurse)
				  (done))
				(cons node visiting)
				visited))))))))))

(define (topological-sort* nodes node-dependencies node-name)
  "Like TOPOLOGICAL-SORT, but don't assume that NODES are roots.  Instead,
consider all nodes in the closure of NODES."
  (define artificial-root (make-symbol "root")) ; uninterned, fresh symbol
  (define nodes* (list artificial-root))
  (define (node-dependencies* node*)
    (if (eq? node* artificial-root)
	nodes
	(node-dependencies node*)))
  (define (node-name* node*)
    (if (eq? node* artificial-root)
	artificial-root
	(node-name node*)))
  (define (proper-node? node*)
    (not (eq? node* artificial-root)))
  (filter proper-node?
	  (topological-sort nodes* node-dependencies* node-name*)))