;;; 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\"."
  ;; It is important to do a breadth-first traversal instead of a depth-first
  ;; traversal -- a simpler depth-first traversal has caused failures in the
  ;; past.
  (define (is-dependency? potential-dependency potential-dependents)
    (member (node-name potential-dependency)
	    (map node-name
		 (append-map node-dependencies potential-dependents))))
  (let loop ((unexpanded-nodes nodes)
	     (result '()) ; in reverse topological order
	     ;; Identical to 'result', except for using a different data
	     ;; structure.
	     (visited (make-hamt hash equal?)))
    (if (null? unexpanded-nodes)
	(reverse result) ; done!
	(let inner-loop ((current-unexpanded-nodes unexpanded-nodes)
			 (later-unexpanded-nodes '())
			 (result result)
			 (visited visited)
			 (progress? #false))
	  (match current-unexpanded-nodes
	    ((first . current-unexpanded-nodes)
	     (cond ((hamt-ref visited (node-name first) #false)
		    ;; Already visisted, nothing to do!
		    (inner-loop current-unexpanded-nodes
				later-unexpanded-nodes result visited
				#true))
		   ;; XXX: would be nice to not recompute
		   ;; 'node-dependencies'.
		   ((is-dependency? first current-unexpanded-nodes)
		    ;; The node was a dependency of something on the previous
		    ;; level, but also of something of the current level.
		    ;; Delay it for later.
		    (inner-loop current-unexpanded-nodes
				(cons first later-unexpanded-nodes)
				result
				visited
				progress?))
		   (#true
		    ;; Expand 'first', putting dependencies in
		    ;; 'later-unexpanded-nodes'.
		    (inner-loop current-unexpanded-nodes
				(append (node-dependencies first)
					later-unexpanded-nodes)
				(cons first result)
				(hamt-set visited (node-name first) #true)
				#true))))
	    (()
	     ;; All nodes on the current level are expanded, descend!
	     ;; But first check for a cycle.
	     (if progress?
		 (loop later-unexpanded-nodes result visited)
		 (error "cycle"))))))))

(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*)))