(use-modules (guix packages)
             (gnu packages)
             (guix build-system emacs)
             (guix git-download)
             (srfi srfi-1)
             (srfi srfi-26)
             (ice-9 match)
             (ice-9 vlist)
             )

(define (all-packages)
  (fold-packages (lambda (package lst)
                   (match (package-replacement package)
                     (#f (cons package lst))
                     (replacement
                      (append (list replacement package) lst))))
                 '()
                 #:select? (negate package-superseded)))

(define melpa-url
  "melpa.org")

(define (melpa? p)
  (match (package-source p)
    ((? origin? o)
     (match (origin-uri o)
       ((url rest ...)
        (string-contains url melpa-url)) ;XXXX: deal with rest?
       ((? string? url)
        (string-contains url melpa-url))
       ((? git-reference? ref)
        (string-contains (git-reference-url ref) melpa-url))
       ;; XXXX: Maybe other methods?
       (_ #false)))
    (_ #false)))

(define (update! table key)
  (match (hash-ref table key 'default)
    ((? number? value)
     (hash-set! table key (1+ value)))
    ('default
      (hash-set! table key 1))))

(define (packages->table)
  (define table (make-hash-table))

  (fold
   (lambda (pkg result)
     (begin
       (if (eq? emacs-build-system (package-build-system pkg))
           (begin
             (update! result 'bs-emacs)
             (if (melpa? pkg)
                 (update! result 'bs-emacs+melpa)
                 (update! result 'bs-emacs-other)))
           (begin
             (update! result 'bs-other)
             (if (melpa? pkg)
                 (update! result 'bs-other+melpa)
                 (update! result 'bs-other-other))))
       result))
   table
   (all-packages)))

(define (format-table)
  (define table
    (packages->table))

  (define (value type)
    (or (hash-ref table type)
        0))

  (define total
    (+ (value 'bs-emacs) (value 'bs-other)))

  (define (percent x tot)
    (* 100. (/ x tot)))

  (format #t "~%")
  (format #t "Emacs: ~2,2f% (~d / ~d)~%" (percent
                                        (value 'bs-emacs)
                                        total)
          (value 'bs-emacs) total)
  (format #t "MELPA: ~2,2f% (~d + ~d / ~d)~%" (percent
                                             (+ (value 'bs-emacs+melpa)
                                                (value 'bs-other+melpa))
                                             total)
          (value 'bs-emacs+melpa) (value 'bs-other+melpa) total)
  (format #t "MELPA/Emacs: ~2,2f% (~d + ~d / ~d)~%"
          (percent
           (+ (value 'bs-emacs+melpa)
              (value 'bs-other+melpa))
           (value 'bs-emacs))
          (value 'bs-emacs+melpa) (value 'bs-other+melpa) (value 'bs-emacs)))

(format-table)