extract-emacs-package.scm

;;; Copyright © 2023 antlers <[email protected]>
;;;
;;; This program 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.
;;;
;;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
;;;
;;; Commentary:
;;;
;;; These ~130 lines parse my `init.el' file into a set of packages.
;;;
;;; There might have been an simpler solution, or a cleaner way to write
;;; the code, but I have this, and it works, so, that'll do.
;;;
;;; Parsing begins when the `use-package' pseudo-keyword `:guix' is
;;; preceded by whitespace or an open paren, and ends at the next
;;; keyword or end-of-form. Specifications may un-nested or wrapped into a
;;; list, comments may be used freely within or to disable, and package
;;; transformation options such as `--with-branch=foo=bar' may be included.
;;;
;;; The list in `parse-options' may need updated to include new keywords.
;;;
;;; Code:

(define-module (antlers home extract-emacs-packages)
  #:use-module (guix transformations)
  #:use-module (gnu packages)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-37)
  #:export (extract-emacs-packages))

(define (maybe-skip-comment char)
  (if (eq? char #\;)
      (let loop ((char (read-char)))
        (if (or (eq? char #\newline)
                (eof-object? char))
            #t
            (loop (read-char))))
      #f))

(define (maybe-skip-string char last)
  (if (and (eq? char #\")
           (not (eq? last #\\)))
      (let loop ((char (read-char))
                 (last last))
        (if (or (eof-object? char)
                (and (eq? char #\"))
                     (not (eq? last #\\)))
            #t
            (loop (read-char) char)))
      #f))

(define* (peek-prefix? prefix #:optional #:key read-match)
  (let loop ((buffer (list (read-char)))
             (tail (string->list prefix)))
    (cond ((null? tail)
           (unless read-match
             (for-each (lambda (c) (unread-char c)) buffer))
           #t)
          ((not (eq? (car buffer)
                     (car tail)))
           (for-each (lambda (c) (unread-char c)) buffer)
           #f)
          (else (loop (cons (read-char) buffer) (cdr tail))))))

(define (extract-emacs-packages filename)
  (define (parse-options args)
    ;; Return the alist of option values.
    (args-fold args
               (map (lambda (key)
                      (option `(,(symbol->string key)) #t #f
                        (lambda (opt name arg result)
                          (alist-cons key arg result))))
                    '(with-source
                      with-branch
                      with-git-url))
               (lambda (opt name arg result)
                 (error "unrecognized option: ~s~%" name))
               (lambda (arg result)
                 (alist-cons 'argument arg result))
               '()))
  (let* ((opts
           (with-input-from-file
             (or (search-path %load-path
                   (string-append (dirname (module-filename (current-module)))
                                  "/" filename))
                 (error "%read-module-relative-file failed for" filename))
             (lambda ()
               (let loop ((char (read-char))
                          (last #\ )
                          (acc-words '()))
                 (cond ((eof-object? char)
                        acc-words)
                       ;; Skip comments and strings
                       ((or (maybe-skip-comment char)
                            (maybe-skip-string char last))
                        (loop (read-char) char acc-words))
                       ;; Loop until we hit a `:'
                       ((not (eq? char #\:))
                        (loop (read-char) char acc-words))
                       ;; Check for `:guix'
                       ((and (char-set-contains?
                               (string->char-set "(" char-set:whitespace)
                               last)
                             (peek-prefix? "guix" #:read-match #t))
                        ;; Consume any whitespace
                        (while (char-set-contains? char-set:whitespace
                                                   (peek-char))
                          (read-char))
                        ;; Collect each package name until we hit a comment, paren,
                        ;; or EOF.
                        (let hit ((char (read-char))
                                  (last #\ )
                                  (acc-chars '())
                                  (nested? #f))
                          (cond ((maybe-skip-comment char)
                                 (hit (read-char) char acc-chars nested?))
                                ((eq? char #\()
                                 (if nested?
                                     (error "depth > 1")
                                     (hit (read-char) char acc-chars  #t)))
                                ;; return to outer loop at end of sexp
                                ((eq? char #\))
                                 (if (not nested?)
                                     (begin
                                       (when (not (null? acc-chars))
                                         (set! acc-words (cons (apply string (reverse acc-chars)) acc-words)))
                                       (loop (read-char) char acc-words))
                                     (hit (read-char) char acc-chars #f)))
                                ;; or at next keyword
                                ((or (and (eq? char #\:)
                                          (char-set-contains?
                                            (string->char-set "(" char-set:whitespace)
                                            last))
                                     (eof-object? char))
                                 (begin
                                   (when (not (null? acc-chars))
                                     (set! acc-words (cons (apply string (reverse acc-chars)) acc-words)))
                                   (loop (read-char) char acc-words)))
                                (else
                                 (cond ((not (char-set-contains? char-set:whitespace char))
                                        (hit (read-char) char (cons char acc-chars) nested?))
                                       ((not (char-set-contains? char-set:whitespace last))
                                        (when (not (null? acc-chars))
                                          (set! acc-words (cons (apply string (reverse acc-chars)) acc-words)))
                                        (hit (read-char) char '() nested?))
                                       (else
                                        (hit (read-char) char acc-chars nested?)))))))
                       (else (loop (read-char) char acc-words)))))))
         (opts (parse-options opts))
         (transform (options->transformation opts))
         (package-specs (append-map (match-lambda
                                      (('argument . (? string? spec)) (list spec))
                                      (_ '()))
                                    opts)))
    (map (lambda (p) (cons (transform (car p)) (cdr p)))
         (specifications->packages package-specs))))