;; FIXME: copyright

(define-module (guix scripts dependencies)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-11)
  #:use-module (ice-9 rdelim)
  #:use-module (guix packages)
  #:use-module (gnu packages audio)
  #:export (display-dependencies))


;; Immutable graph datastructure

;; FIXME: Taken from Guile, should be in (srfi srfi-99)
;;        adapted to make it possible to declare record type like `<abc>' and keep
;;        field accessor bracket free. record name *must* have brackets or everything
;;        is broken
;;
;; Usage:
;;
;;   (define-record-type <abc> field-one field-two)
;;   (define zzz (make-abc 1 2))
;;   (abc-field-one zzz) ;; => 1
;;
;; FIXME: maybe this is less useful than the immutable record of (srfi srfi-9 gnu)
;;        Right I will use `set-field` and `set-fields`
(define-syntax define-record-type*
  (lambda (x)
    (define (%id-name name) (string->symbol (string-drop (string-drop-right (symbol->string name) 1) 1)))
    (define (id-name ctx name)
      (datum->syntax ctx (%id-name (syntax->datum name))))
    (define (id-append ctx . syms)
      (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
    (syntax-case x ()
      ((_ rname field ...)
       (and (identifier? #'rname) (and-map identifier? #'(field ...)))
       (with-syntax ((cons (id-append #'rname #'make- (id-name #'rname #'rname)))
                     (pred (id-append #'rname (id-name #'rname #'rname) #'?))
                     ((getter ...) (map (lambda (f)
                                          (id-append f (id-name #'rname #'rname) #'- f))
                                        #'(field ...))))
         #'(define-record-type rname
             (cons field ...)
             pred
             (field getter)
             ...))))))

(define-record-type* <node> identifier label outgoings incomings properties)


;;;
;;; Store
;;;
;;; Memory bound immutable association
;;;


;; XXX: It's assumed that keys are strings.
;;
;; This replace scheme assoc, because:
;; 1) there is no immutable `assoc-set` in scheme
;; 2) `acons` (and friends) can replace `assoc-set` but memory will grow without bound
;; 3) `assoc-ref` (and friends) always return `#f` when no values is found
;; 4) `vlist` and else can not be easily written to disk
;; 5) It's fun


(define (store-set store key value)
  "Return a copy of STORE where KEY is set to VALUE"
  (let loop ((assoc store)
             (out '()))
    (if (null? assoc)
        (cons (cons key value) out)
        (if (equal? (caar assoc) key)
            (append (list (cons key value)) out (cdr assoc))
            (loop (cdr assoc) (cons (car assoc) out))))))


(define (store-ref store key)
  "Return the value of KEY in STORE, if KEY is not found return #nil"
  (let loop ((assoc store))
    (if (null? assoc)
        #nil
        (if (equal? (caar assoc) key)
            (cdar assoc)
            (loop (cdr assoc))))))

(define (store-del store key)
  "Return a copy of STORE where the KEY association doesn't exists"
  (let loop ((assoc store)
             (out '()))
    (if (null? assoc)
        store
        (if (equal? (caar assoc) key)
            (append out (cdr assoc))
            (loop (cdr assoc) (cons (car assoc) out))))))


;;;
;;; Graph
;;;

(define-record-type* <graph> label nodes edges properties)


(set-record-type-printer! <graph>
  (lambda (record port)
    (display "<graph  label: \"" port)
    (display (graph-label record) port)
    (display "\" nodes: " port)
    (display (length (graph-nodes record)) port)
    (display " edges: " port)
    (display (length (graph-edges record)) port)
    (display " properties: " port)
    (display (length (graph-properties record)) port)
    (display ">" port)))

(define (create-graph label)
  (make-graph label '() '() '()))

(define (graph-get-uid store)
  (define CHARS "AZERTYUIOPQSDFGHJKLMWXCVBN1029384756")

  (define (random-id)
    (let loop ((count 4)
               (id ""))
      (if (eq? count 0)
          id
          (loop (1- count) (format #f "~a~a" id (string-ref CHARS (random 36)))))))

  (let loop ()
    (let ((id (random-id)))
      (if (null? (store-ref store id))
          id
          (loop)))))

;; properties get/set/ref

(define (graph-property-set graph key value)
  (let* ((properties (graph-properties graph)))
    (set-field graph (graph-properties) (store-set properties key value))))

(define (graph-property-del graph key)
  (let* ((properties (graph-properties graph)))
    (set-field graph (graph-properties) (store-del properties key))))

(define (graph-property-ref graph key)
  (let* ((properties (graph-properties graph)))
    (store-ref properties key)))


;;;
;;; Node
;;;

(define-record-type* <node> identifier label outgoings incomings properties)

(define (graph-create-node graph label)
  (let* ((uid (graph-get-uid (graph-nodes graph)))
         (node (make-node uid label '() '() '()))
         (graph (set-field graph (graph-nodes) (store-set (graph-nodes graph) uid node))))
    (values graph (node-identifier node))))

(define (graph-node-ref graph uid)
  (store-ref (graph-nodes graph) uid))

(define (graph-node-label-ref graph label)
  (graph-node-ref graph (graph-property-ref graph label)))

(define (graph-node-property-set graph uid key value)
  (let* ((node (graph-node-ref graph uid))
        (properties (node-properties node))
        (node (set-field  node (node-properties) (store-set properties key value)))
        (nodes (graph-nodes graph)))
    (set-field graph (graph-nodes) (store-set nodes uid node))))

(define (graph-node-property-del graph uid key)
  (let* ((node (graph-node-ref graph uid))
        (properties (node-properties node))
        (node (set-field  node (node-properties) (store-del properties key)))
        (nodes (graph-nodes graph)))
    (set-field graph (graph-nodes) (store-set nodes uid node))))

(define (graph-node-property-ref graph uid key)
  (let* ((node (graph-node-ref graph uid))
         (properties (node-properties node)))
    (store-ref properties key)))

(define (%graph-node-edges graph uid edges-getter)
  (let loop ((edges (edges-getter (graph-edge-ref graph uid)))
             (out '()))
    (if (null? edges)
        out
        (loop (cdr edges) (cons (graph-edge-ref graph (car edges)) out)))))

(define (graph-node-outgoings graph uid)
  (%graph-node-edges graph uid node-outgoings))

(define (graph-node-incomings graph uid)
  (%graph-node-edges graph uid node-incomings))

;;;
;;; Edge
;;;

(define-record-type* <edge> identifier start label end properties)

(define (graph-create-edge graph start label end)
  (let* ((uid (graph-get-uid (graph-edges graph)))
         (edge (make-edge uid start label end '()))
         (nodes (graph-nodes graph))

         ;; add edge to `outgoings` of `start` node
         (start-node (graph-node-ref graph start))
         (outgoings (node-outgoings start-node))
         (outgoings (cons uid outgoings))
         (start-node (set-field start-node (node-outgoings) outgoings))
         (nodes (store-set nodes start start-node))

         ;; add edge to `incomings` of `end` node
         (end-node (graph-node-ref graph end))
         (incomings (node-incomings end-node))
         (incomings (cons uid incomings))
         (end-node (set-field end-node (node-incomings) incomings))
         (nodes (store-set nodes end end-node))

         ;; updates `nodes` field
         (graph (set-field graph (graph-nodes) nodes)))
    (values (set-field graph (graph-edges) (store-set (graph-edges graph) uid edge))
            (edge-identifier edge))))

(define (graph-edge-ref graph uid)
  (store-ref (graph-edges graph) uid))

(define (graph-edge-property-set graph uid key value)
  (let* ((edge (graph-edge-ref graph uid))
        (properties (edge-properties edge))
        (edge (set-field  edge (edge-properties) (store-set properties key value)))
        (edges (graph-edges graph)))
    (set-field graph (graph-edges) (store-set edges uid edge))))

(define (graph-edge-property-del graph uid key)
  (let* ((edge (graph-edge-ref graph uid))
        (properties (edge-properties edge))
        (edge (set-field  edge (edge-properties) (store-del properties key)))
        (edges (graph-edges graph)))
    (set-field graph (graph-edges) (store-set edges uid edge))))

(define (graph-edge-property-ref graph uid key)
  (let* ((edge (graph-edge-ref graph uid))
         (properties (edge-properties edge)))
    (store-ref properties key)))

(define (graph-edge-start graph uid)
  (let* ((edge (graph-edge-ref graph uid)))
    (graph-node-ref graph (edge-start edge))))

(define (graph-edge-end graph uid)
  (let* ((edge (graph-edge-ref graph uid)))
    (graph-node-ref graph (edge-end edge))))


;; Build dependency graph of a guix package

(define (maybe-create-node graph label)
  (if (graph-property-ref graph label)
      (values graph (graph-property-ref graph label))
      (let-values (((graph uid) (graph-create-node graph label)))
        (values (graph-property-set graph label uid) uid))))

(define (maybe-create-edge graph start label end)
  (if (graph-property-ref graph label)
      (values graph (graph-property-ref graph label))
      (let-values (((graph uid) (graph-create-edge graph start label end)))
        (values (graph-property-set graph label uid) uid))))

(define (package-dependency-graph package graph)
  (let loop ((packages (package-inputs package))
             (graph graph))
    (if (null? packages)
        graph
        (if (package? (cadar packages))
            (let ((dependency (package-name (cadar packages))))
              (let*-values (((graph package-uid) (maybe-create-node graph (package-name package)))
                            ((graph dependency-uid) (maybe-create-node graph dependency)))
                (let* ((label (string-append (package-name (cadar packages)) "--(depends)-->" dependency))
                       (graph (maybe-create-edge graph package-uid label dependency-uid))
                       (graph (package-dependency-graph (cadar packages) graph)))
                (loop (cdr packages) graph))))
            (loop (cdr packages) graph)))))

(define (graph-dot graph port)
  (format port
          "digraph \"dependency graph of ~a\" {\n\tratio = \"auto\";\n\tmincross = 3.0;\n\tlabel = \"~a\"\n\n"
          (graph-label graph)
          (graph-label graph))
  (let loop ((edges (graph-edges graph)))
    (if (null? edges)
        (format port "\n}\n")
        (begin
          (format port "\t\"~a\" -> \"~a\";\n"
                  (node-label (graph-node-ref graph (edge-start (cdar edges))))
                  (node-label (graph-node-ref graph (edge-end (cdar edges)))))
          (loop (cdr edges))))))


(define (display-dependencies package port)
  (let* ((graph (create-graph (string-append "dependencies of " (package-name package))))
         (graph (package-dependency-graph package graph)))
    (graph-dot graph port)
    graph))