Skip to content

Instantly share code, notes, and snippets.

@antler5
Created January 8, 2024 22:45
Show Gist options
  • Save antler5/b3090d73b97779f977105b905be14453 to your computer and use it in GitHub Desktop.
Save antler5/b3090d73b97779f977105b905be14453 to your computer and use it in GitHub Desktop.
;;; Copyright © 2023 antlers <antlers@illucid.net>
;;;
;;; 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))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment