;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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/>.

(define-module (test-graph)
  #:use-module (guix tests)
  #:use-module (guix graph)
  #:use-module (guix scripts graph)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix grafts)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system trivial)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages libunistring)
  #:use-module (gnu packages bootstrap)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64))

(define %store
  (open-connection-for-tests))

;; Globally disable grafts because they can trigger early builds.
(%graft? #f)

(define (make-recording-backend)
  "Return a <graph-backend> and a thunk that returns the recorded nodes and
edges."
  (let ((nodes '())
        (edges '()))
    (define (record-node id label port)
      (set! nodes (cons (list id label) nodes)))
    (define (record-edge source target port)
      (set! edges (cons (list source target) edges)))
    (define (return)
      (values (reverse nodes) (reverse edges)))

    (values (graph-backend "test" "This is the test backend."
                           (const #t) (const #t)
                           record-node record-edge)
            return)))

(define (package->tuple package)
  "Return a tuple representing PACKAGE as produced by %PACKAGE-NODE-TYPE."
  (list (object-address package)
        (package-full-name package)))

(define (edge->tuple source target)
  "Likewise for an edge from SOURCE to TARGET."
  (list (object-address source)
        (object-address target)))


(test-begin "graph")

(test-assert "package DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let* ((p1 (dummy-package "p1"))
           (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
           (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
      (run-with-store %store
        (export-graph (list p3) 'port
                      #:node-type %package-node-type
                      #:backend backend))
      ;; We should see nothing more than these 3 packages.
      (let-values (((nodes edges) (nodes+edges)))
        (and (equal? nodes (map package->tuple (list p3 p2 p1)))
             (equal? edges
                     (map edge->tuple
                          (list p3 p3 p2)
                          (list p2 p1 p1))))))))

(test-assert "reverse package DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (export-graph (list libunistring) 'port
                    #:node-type %reverse-package-node-type
                    #:backend backend))
    ;; We should see nothing more than these 3 packages.
    (let-values (((nodes edges) (nodes+edges)))
      (and (member (package->tuple guile-2.0) nodes)
           (->bool (member (edge->tuple libunistring guile-2.0) edges))))))

(test-assert "bag-emerged DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let* ((o        (dummy-origin (method (lambda _
                                             (text-file "foo" "bar")))))
           (p        (dummy-package "p" (source o)))
           (implicit (map (match-lambda
                            ((label package) package)
                            ((label package output) package))
                          (standard-packages))))
      (run-with-store %store
        (export-graph (list p) 'port
                      #:node-type %bag-emerged-node-type
                      #:backend backend))
      ;; We should see exactly P and IMPLICIT, with one edge from P to each
      ;; element of IMPLICIT.  O must not appear among NODES.  Note: IMPLICIT
      ;; contains "glibc" twice, once for "out" and a second time for
      ;; "static", hence the 'delete-duplicates' call below.
      (let-values (((nodes edges) (nodes+edges)))
        (and (equal? (match nodes
                       (((labels names) ...)
                        names))
                     (map package-full-name
                          (cons p (delete-duplicates implicit))))
             (equal? (match edges
                       (((sources destinations) ...)
                        (zip (map store-path-package-name sources)
                             (map store-path-package-name destinations))))
                     (map (lambda (destination)
                            (list "p-0.drv"
                                  (string-append
                                   (package-full-name destination)
                                   ".drv")))