guix-api-examples/purge-python2-packages.scm

#!/usr/bin/env -S guile --no-auto-compile -e main
!#
(use-modules (gnu packages)
             (gnu packages python)
             (guix diagnostics)
             (guix graph)
             (guix monads)
             (guix scripts graph)
             (guix scripts style)
             (guix store)
             (guix packages)
             (guix build utils)
             (guix utils)
             (ice-9 match)
             (ice-9 popen)
             (ice-9 pretty-print)
             (ice-9 textual-ports)
             (srfi srfi-1)
             (srfi srfi-2)
             (srfi srfi-26))

;;; Commentary:
;;;
;;; Find all the leaf (0 dependents) Python 2 packages, delete them,
;;; and de-register any "python2-variant" property that referred to
;;; them from a Python 3 same-named package.

(define (all-packages)
  (fold-packages (lambda (package result)
                   (cons package result))
                 '()))

(define (list-dependents package)
  "List the packages dependents on PACKAGE."
  (with-store store
    (run-with-store store
      (mlet* %store-monad ((edges (node-back-edges
                                   %bag-node-type
                                   (package-closure (all-packages)))))
        (return (node-transitive-edges (list package) edges))))))

(define (locate-package-via-git name)
  "Return the location object corresponding to package NAME, searched via git."
  (let* ((input-pipe (open-pipe* OPEN_READ
				 "git" "grep" "-n" "--column"
                                 (format #f "^(define-public ~a$" name)))
	 (output (get-string-all input-pipe)) ;file:line:column:match
	 (exit-val (status:exit-val (close-pipe input-pipe))))
    (case exit-val
      ((0)
       (let ((components (string-split output #\:)))
         (location
          (first components)                   ;file
          (string->number (second components)) ;1-indexed line
          ;; FIXME: Comment discrepancy in (guix diagnostics), which
          ;; says the column is 0-indexed.
          (and=> (string->number (third components)) 1-)))) ;0-indexed column
      ((1) #f)                                            ;no match
      (else (error "git grep failed with status" exit-val)))))

(define (delete-package-field field sexp)
  "Delete FIELD (a symbol) from a package SEXP."
  (match sexp
    ;; TODO: Can we come up with a general pattern here?
    (('define-public name ('package (fields ...) ...))
     `(define-public ,name
        (package
          ,@(alist-delete field fields))))
    (('define-public name ('package/inherit parent (fields ...) ...))
     `(define-public ,name
        (package/inherit ,parent
          ,@(alist-delete field fields))))
    (('define-public name ('hidden-package ('package (fields ...) ...)))
     `(define-public ,name
        (hidden-package
         (package ,@(alist-delete field fields)))))
    (('define-public name ('hidden-package
                           ('package/inherit parent (fields ...) ...)))
     `(define-public ,name
        (hidden-package
         (package/inherit ,parent
           ,@(alist-delete field fields)))))))

;;; Potential improvement suggested by daviid (to try).
;; (define (delete-package-field field sexp)
;;   "Delete FIELD (a symbol) from a package SEXP."
;;   (match sexp
;;     ;; TODO: Can we come up with a general pattern here?
;;     (('define-public name package-def ...)
;;      `(define-public ,name
;;         ,(update-package-def package-def field)))))

;; (define (update-package-def package-def field)
;;   (match package-def
;;     (('package (fields ...) ...)
;;      `(package
;;        ,@(alist-delete field fields)))
;;     (('package/inherit parent (fields ...) ...)
;;      `(package/inherit ,parent
;;                        ,@(alist-delete field fields)))
;;     (('hidden-package ('package (fields ...) ...))
;;      `(hidden-package
;;        (package ,@(alist-delete field fields))))
;;     (('hidden-package ('package/inherit parent (fields ...) ...))
;;      `(hidden-package (package/inherit ,parent
;;                                        ,@(alist-delete field fields))))))

(define (delete-package-property-helper property fields)
  "Return a patched copy of a package fields."
  (let* ((properties (assoc-ref fields 'properties))
         (new-properties (sexp-filter (remove-node property) properties)))
    (alist-replace 'properties new-properties fields)))

(define (delete-package-property property sexp)
  "Delete a specific PROPERTY (a symbol) from a package SEXP."
  (match sexp
    (('define-public name ('package (fields ...) ...))
     `(define-public ,name
        (package ,@(delete-package-property-helper property fields))))
    (('define-public name ('package/inherit parent (fields ...) ...))
     `(define-public ,name
        (package/inherit ,parent
          ,@(delete-package-property-helper property fields))))
    (('define-public name ('hidden-package ('package (fields ...) ...)))
     `(define-public ,name
        (hidden-package
         (package ,@(delete-package-property-helper property fields)))))
    (('define-public name ('hidden-package
                           ('package/inherit parent (fields ...) ...)))
     `(define-public ,name
        (hidden-package
         (package/inherit ,parent
           ,@(delete-package-property-helper property fields)))))))

(define (delete-leaf-python-package package)
  "Delete the package, and de-register any variant property."
  (with-directory-excursion (%guix-source-root-directory)
    (let* ((name (package-name package))
           (py3name (string-replace-substring name "python2" "python"))
           ;; XXX: Due to https://issues.guix.gnu.org/55139, and also
           ;; the fact that we are editing the sources at run time
           ;; without re-evaluating the modules, we rely on git to
           ;; locate the package definition.
           (source-properties (and=> (locate-package-via-git name)
                                     location->source-properties)))

      (format #t "Deleting package ~s...~%" name)
      ;; Note: the line is decremented by one so the blank line
      ;; separating the package definitions is also removed.
      (delete-expression (alist-replace
                          'line (1- (assoc-ref source-properties 'line))
                          source-properties))

      ;; Check if a same-named Python 3 package had a python2-variant
      ;; entry for it.
      (and-let* ((py3package (match (find-packages-by-name py3name)
                               (() #f)
                               ((p p* ...)
                                p)))
                 (properties (package-properties py3package))
                 (python2-variant (and=> (assoc-ref properties 'python2-variant)
                                         force))
                 (source-properties (and=> (locate-package-via-git py3name)
                                           location->source-properties)))
        (when (and (eq? python2-variant package))
          (format #t "Removing 'python2-variant' property from package ~a...~%"
                  py3name)
          (edit-expression
           source-properties
           (lambda (expr)
             (let ((sexp (call-with-input-string expr read)))
               (string-trim             ;remove added \n
                (call-with-output-string
                  (lambda (port)
                    (pretty-print-with-comments
                     port
                     (if (= 1 (length properties))
                         (delete-package-field 'properties sexp)
                         (delete-package-property 'python2-variant sexp)))))))))
          #t)))))

(define (main _)
  (define skipped-packages
    (fold-packages
     (lambda (package lst)
       (let ((python-arg (and=> (member #:python
                                        (package-arguments package))
                                second)))
         (if (eq? python-2 python-arg)
             (let* ((dependents (list-dependents package))
                    (name (package-name package))
                    (dependent-count (length dependents)))
               (case dependent-count
                 ((0)
                  (delete-leaf-python-package package)
                  (format #t "Committing '~a' package removal...~%" name)
                  (with-directory-excursion (%guix-source-root-directory)
                    (invoke "./etc/committer.scm"))
                  lst)
                 (else
                  (format #t "Skipping package '~a' with ~a dependents...~%"
                          name dependent-count)
                  (cons (list name dependent-count) lst))))
             lst)))
     '()))

  (newline)
  (format #t "Python 2 purge complete.~%")
  (format #t "~a packages were kept due to having dependents:~%"
          (length skipped-packages))
  ;; Sort the skipped packages by descending number of dependencies.
  (define skipped-packages/sorted (sort skipped-packages
                                        (lambda (x y)
                                          (> (second x) (second y)))))
  (pretty-print-table (cons (list "Packages" "Dependencies")
                            skipped-packages/sorted)))


;;;
;;; Sexp-munging procedures.
;;;

;;; sexp-filter and removed-node co-authored by daviid; thank you!
(define (sexp-filter proc sexp)
  "Filter SEXP recursively using PROC."
  (match sexp
    (() sexp)
    (((a rest))
     (cons (sexp-filter proc (car sexp))
           (sexp-filter proc (cdr sexp))))
    ((a rest)
     (cons a (list (proc rest))))))

(define (remove-node key)
  (lambda (props)
    (filter-map (lambda (prop)
                  (match prop
                    ((k . v)
                     (and (not (eq? k key)) prop))))
                props)))