update

(define-module (scripts update)
  #:use-module (guile)
  #:use-module (guix build utils)
  #:use-module (guix http-client)
  #:use-module (emacs import melpa)
  #:use-module (guix packages)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 textual-ports)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-43)
  #:use-module (web uri)
  #:export (main))

(define-record-type <archive-entry>
  (make-archive name raw-name version deps)
  archive?
  (name archive-name)
  (raw-name archive-raw-name)
  (version archive-version)
  (deps archive-deps set-archive-deps!))

(define %root
  (dirname (canonicalize-path (dirname (or (current-filename) "./update")))))

(define %melpa-path (string-append %root "/emacs/packages/melpa.scm"))

(define copyright (call-with-input-file (string-append %root "/etc/melpa-copyright") get-string-all))

(define header
  '((define-module (emacs packages melpa)
      #:use-module (emacs build-system melpa)
      #:use-module (emacs packages elpa)
      #:use-module (guix download)
      #:use-module (guix git-download)
      #:use-module (guix packages)
      #:use-module (gnu packages emacs-xyz)
      #:export (packages))
    (module-use-interfaces! (current-module) (module-uses (resolve-module '(gnu packages emacs-xyz))))))

(define overrides (call-with-input-file (string-append %root "/emacs/packages/melpa-overrides") get-string-all))

(define (string->emacs-package-name str)
  (string->symbol (string-append "emacs-" str)))

(define (list-car-index key list)
  (list-index (lambda (c) (eq? (car c) key)) list))

(define emacs-standard-library?
  (let ((libs
	 (cons* 'emacs
		'emacs-emacs ; since the deps are prefix, this is a workaround to remove emacs from deps
		;; Generated with: rg "^\(provide ('([\w-]+))+\)" -r '$2' -N --no-heading --no-filename -o | sort
		(with-input-from-file (string-append %root "/etc/emacs-libs")
		  (lambda ()
		    (map string->emacs-package-name
			 (remove string-null?
				 (string-split (get-string-all (current-input-port))
					       #\newline))))))))
    (lambda (lib)
      (memq lib libs))))

(define (valid-source? source)
  (let* ((sha256 (assq-ref (cdar source) 'sha256))
	 (base32 (cadar sha256)))
    (not (equal? base32 "failed to download package"))))

(define (limit-description description)
  (let ((splitted (string-split (second description) #\newline)))
    `(description ,(string-join (take splitted (min 10 (length splitted))) "\n"))))

(define (fetch-archive url)
  "Fetch archive.json from the melpa URL. The data will automatically be converted to scheme form."
  (let* ((port (http-fetch/cached (string->uri url)
				  #:ttl (* 6 3600)))
	 (data (json->scm port)))
    (close-port port)
    data))

(define (archive-version->string ver)
  "Convert VER to a string like 0.1.2. VER must be a vector."
  (if (vector? ver)
      (let* ((ver-list (vector->list ver))
	     (state (number->string (car ver-list)))
	     (rest (cdr ver-list)))
	(fold (lambda (val state) (string-append state "." (number->string val)))
	      state
	      rest))
      #f))

(define (archive-entry->package archive-entry)
  "Fetch ARCHIVE to produce a Guix package."
  (let ((name (archive-name archive-entry))
	(version (archive-version archive-entry)))
    (let* ((package (melpa->guix-package (archive-raw-name archive-entry)))
	   (pkg-content (cdr package))
	   (description-idx (list-car-index 'description pkg-content))
	   (source (assq-ref pkg-content 'source)))
      (unless (valid-source? source)
	(error (format #false "invalid source for package ~a" name)))
      (when description-idx
	(list-set! pkg-content
		   description-idx
		   (limit-description (list-ref pkg-content description-idx))))
      package)))

(define (newline-rewriting-port output)
  "Return an output port that rewrites strings containing the \\n escape
to an actual newline.  This works around the behavior of `pretty-print'
and `write', which output these as \\n instead of actual newlines,
whereas we want the `description' field to contain actual newlines
rather than \\n."
  (define (write-string str)
    (let loop ((chars (string->list str)))
      (match chars
        (()
         #t)
        ((#\\ #\n rest ...)
         (newline output)
         (loop rest))
        ((chr rest ...)
         (write-char chr output)
         (loop rest)))))

  (make-soft-port (vector (cut write-char <>)
                          write-string
                          (lambda _ #t)	; flush
                          #f
                          (lambda _ #t)	; close
                          #f)
                  "w"))

(define ignore-archive?
  (let ((archives '("@" "nov" "timp")))
    (lambda (archive)
      (member (first archive) archives))))

(define emacs-xyz-module (resolve-module '(gnu packages emacs-xyz)))
(define emacs-elpa-module (resolve-module '(emacs packages elpa)))

(define* (resolve-archive package-name resolved-entries final-entries)
  (let ((handle (hashq-get-handle resolved-entries package-name))
	    (entry (hashq-ref final-entries package-name)))
    (if (not handle)
	    (begin
	      (if entry
	          (let loop ((deps (archive-deps entry)))
		        (match deps
		          ((dep rest ...)
		           (if (or (resolve-archive dep resolved-entries final-entries)
			               (module-variable emacs-xyz-module dep)
                           (module-variable emacs-elpa-module dep))
		               (loop rest)
		               (begin
			             (format #t "[~a] excluded package: dep ~a not found~%" package-name dep)
			             (hashq-set! resolved-entries package-name #f)
			             (hashq-remove! final-entries package-name)
			             #f)))
		          (()
		           (hashq-set! resolved-entries package-name entry)
		           entry)))
	          #f))
	    (cdr handle))))

(define (filter-archive archive)
  (let ((entries (make-hash-table)))
    (for-each (lambda (entry)
		(let* ((raw-name (car entry))
		       (name (string->emacs-package-name (string-downcase raw-name)))
		       (rest (cdr entry))
		       (version (archive-version->string (cdr (assoc "ver" rest))))
		       (deps  (cdr (assoc "deps" rest))))
		  (hashq-set! entries name
			      (make-archive name raw-name version
					    (if (eq? deps 'null)
						'()
						(map (compose string->emacs-package-name string-downcase car) deps))))))
	      archive)
    (hash-for-each (lambda (key value)
		     (set-archive-deps! value (remove emacs-standard-library? (archive-deps value))))
		   entries)
    (let ((resolved-entries (make-hash-table)))
      (hash-for-each (lambda (key value) (resolve-archive key resolved-entries entries)) entries))
    entries))

(define (read-packages path)
  "Read packages from PATH. Returns hash map with package name as a key
and package literal as a value.

  ('package-name . (package (name \"emacs-package-name\")))"
  (let ((input-file (open-input-file path))
	    (packages (make-hash-table)))
    (let loop ((input (read input-file)))
      (unless (eof-object? input)
	    (when (eq? (first input) 'define-public)
	      (hashq-set! packages (second input) (third input)))
	    (loop (read input-file))))
    (close-port input-file)
    packages))

(define (read-package-version package-lit)
  "Read package version from PACKAGE-LIT (literal value)."
  (let ((alist (cdr package-lit)))
    (car (assq-ref alist 'version))))

(define (update-packages packages archive)
  (hash-for-each
   (lambda (key archive-entry)
     (let ((package (hashq-ref packages key))
	   (set-package! (lambda (package)
			  (when package
			    (hashq-set! packages key package)))))
       (catch #t
	 (lambda ()
	   (if package
	       (unless (equal? (archive-version archive-entry) (read-package-version package))
		 (format #t "package ~a: ~a => ~a~%" key (archive-version archive-entry) (read-package-version package))
		 (set-package! (archive-entry->package archive-entry)))
	       (begin
		 (format #t "new package: ~a~%" key)
		 (set-package! (archive-entry->package archive-entry)))))
	 (lambda* (#:rest e)
	   (format #t "[~a] error: ~%~a~%" key e)
	   #f))))
   archive)
  (hash-for-each
   (lambda (key value)
     (unless (hashq-ref archive key)
       (format #t "removing package: ~a~%" key)
       (hashq-remove! packages key)))
   packages))

(define (main args)
  (mkdir-p "emacs/packages")
  (let* ((packages (read-packages %melpa-path))
	     (archive (filter-archive (remove ignore-archive? (fetch-archive "https://melpa.org/archive.json"))))
	     (archive-count (hash-count (const #t) archive))
	     (i 0)
	     (out (newline-rewriting-port (open-output-file %melpa-path))))
    (format #t "Total archives: ~a~%" archive-count)
    (update-packages packages archive)
    (format out copyright)
    (for-each (lambda (h) (pretty-print h out) (write-char #\newline out)) header)
    (let ((packages-list (sort (hash-map->list cons packages)
			                   (lambda (y x)
				                 (let ((name (lambda (v)
					                           (symbol->string (car v)))))
			                       (string<? (name y) (name x)))))))
      (for-each (lambda (entry)
		          (let ((package-name (car entry))
			            (package (cdr entry)))
		            (set! i (+ i 1))
		            (format #t "[~a/~a] writing package ~a...~%" i archive-count package-name)
		            (pretty-print `(define-public ,package-name ,package) out)
		            (write-char #\newline out)))
		        packages-list)
      (format out overrides))
    (close-port out)
    (display "Done!")))

(main (command-line))