diff options
Diffstat (limited to 'emacs/guix-main.scm')
| -rw-r--r-- | emacs/guix-main.scm | 603 |
1 files changed, 603 insertions, 0 deletions
diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm new file mode 100644 index 0000000000..1383d08830 --- /dev/null +++ b/emacs/guix-main.scm @@ -0,0 +1,603 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Alex Kost <alezost@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix 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. +;;; +;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Information about packages and generations is passed to the elisp +;; side in the form of alists of parameters (such as ‘name’ or +;; ‘version’) and their values. These alists are called "entries" in +;; this code. So to distinguish, just "package" in the name of a +;; function means a guile object ("package" record) while +;; "package entry" means alist of package parameters and values (see +;; ‘package-param-alist’). +;; +;; "Entry" is probably not the best name for such alists, because there +;; already exists "manifest-entry" which has nothing to do with the +;; "entry" described above. Do not be confused :) + +;; ‘get-entries’ function is the “entry point” for the elisp side to get +;; information about packages and generations. + +;; Since name/version pair is not necessarily unique, we use +;; `object-address' to identify a package (for ‘id’ parameter), if +;; possible. However for the obsolete packages (that can be found in +;; installed manifest but not in a package directory), ‘id’ parameter is +;; still "name-version" string. So ‘id’ package parameter in the code +;; below is either an object-address number or a full-name string. +;; +;; Important: as object addresses live only during guile session, elisp +;; part should take care about updating information after "Guix REPL" is +;; restarted (TODO!) +;; +;; ‘installed’ parameter of a package entry contains information about +;; installed outputs. It is a list of "installed entries" (see +;; ‘package-installed-param-alist’). + +;; To speed-up the process of getting information, the following +;; auxiliary variables are used: +;; +;; - `%packages' - VHash of "package address"/"package" pairs. +;; +;; - `%package-table' - Hash table of +;; "name+version key"/"list of packages" pairs. +;; +;; - `%current-manifest-entries-table' - Hash table of +;; "name+version key"/"list of manifest entries" pairs. This variable +;; is set by `set-current-manifest-maybe!' when it is needed. + +;;; Code: + +(use-modules + (ice-9 vlist) + (ice-9 match) + (srfi srfi-1) + (srfi srfi-11) + (srfi srfi-19) + (srfi srfi-26) + (guix) + (guix packages) + (guix profiles) + (guix licenses) + (guix utils) + (guix ui) + (guix scripts package) + (gnu packages)) + +(define-syntax-rule (first-or-false lst) + (and (not (null? lst)) + (first lst))) + +(define full-name->name+version package-name->name+version) +(define (name+version->full-name name version) + (string-append name "-" version)) + +(define* (make-package-specification name #:optional version output) + (let ((full-name (if version + (name+version->full-name name version) + name))) + (if output + (string-append full-name ":" output) + full-name))) + +(define name+version->key cons) +(define key->name+version car+cdr) + +(define %current-manifest #f) +(define %current-manifest-entries-table #f) + +(define %packages + (fold-packages (lambda (pkg res) + (vhash-consq (object-address pkg) pkg res)) + vlist-null)) + +(define %package-table + (let ((table (make-hash-table (vlist-length %packages)))) + (vlist-for-each + (lambda (elem) + (match elem + ((address . pkg) + (let* ((key (name+version->key (package-name pkg) + (package-version pkg))) + (ref (hash-ref table key))) + (hash-set! table key + (if ref (cons pkg ref) (list pkg))))))) + %packages) + table)) + +;; FIXME get rid of this function! +(define (set-current-manifest-maybe! profile) + (define (manifest-entries->hash-table entries) + (let ((entries-table (make-hash-table (length entries)))) + (for-each (lambda (entry) + (let* ((key (name+version->key + (manifest-entry-name entry) + (manifest-entry-version entry))) + (ref (hash-ref entries-table key))) + (hash-set! entries-table key + (if ref (cons entry ref) (list entry))))) + entries) + entries-table)) + + (when profile + (let ((manifest (profile-manifest profile))) + (unless (and (manifest? %current-manifest) + (equal? manifest %current-manifest)) + (set! %current-manifest manifest) + (set! %current-manifest-entries-table + (manifest-entries->hash-table + (manifest-entries manifest))))))) + +(define (manifest-entries-by-name+version name version) + (or (hash-ref %current-manifest-entries-table + (name+version->key name version)) + '())) + +(define (packages-by-name+version name version) + (or (hash-ref %package-table + (name+version->key name version)) + '())) + +(define (packages-by-full-name full-name) + (call-with-values + (lambda () (full-name->name+version full-name)) + packages-by-name+version)) + +(define (package-by-address address) + (and=> (vhash-assq address %packages) + cdr)) + +(define (packages-by-id id) + (if (integer? id) + (let ((pkg (package-by-address id))) + (if pkg (list pkg) '())) + (packages-by-full-name id))) + +(define (package-by-id id) + (first-or-false (packages-by-id id))) + +(define (newest-package-by-id id) + (and=> (id->name+version id) + (lambda (name) + (first-or-false (find-best-packages-by-name name #f))))) + +(define (id->name+version id) + (if (integer? id) + (and=> (package-by-address id) + (lambda (pkg) + (values (package-name pkg) + (package-version pkg)))) + (full-name->name+version id))) + +(define (fold-manifest-entries proc init) + "Fold over `%current-manifest-entries-table'. +Call (PROC NAME VERSION ENTRIES RESULT) for each element of the hash +table, using INIT as the initial value of RESULT." + (hash-fold (lambda (key entries res) + (let-values (((name version) (key->name+version key))) + (proc name version entries res))) + init + %current-manifest-entries-table)) + +(define (fold-object proc init obj) + (fold proc init + (if (list? obj) obj (list obj)))) + +(define* (object-transformer param-alist #:optional (params '())) + "Return function for transforming an object into alist of parameters/values. + +PARAM-ALIST is alist of available object parameters (symbols) and functions +returning values of these parameters. Each function is called with object as +a single argument. + +PARAMS is list of parameters from PARAM-ALIST that should be returned by a +resulting function. If PARAMS is not specified or is an empty list, use all +available parameters. + +Example: + + (let ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>)))) + (number->alist (object-transformer alist '(plus1 mul2)))) + (number->alist 8)) + => + ((plus1 . 9) (mul2 . 16)) +" + (let ((alist (let ((use-all-params (null? params))) + (filter-map (match-lambda + ((param . fun) + (and (or use-all-params + (memq param params)) + (cons param fun))) + (_ #f)) + param-alist)))) + (lambda (object) + (map (match-lambda + ((param . fun) + (cons param (fun object)))) + alist)))) + +(define package-installed-param-alist + (list + (cons 'output manifest-entry-output) + (cons 'path manifest-entry-item) + (cons 'dependencies manifest-entry-dependencies))) + +(define manifest-entry->installed-entry + (object-transformer package-installed-param-alist)) + +(define (manifest-entries->installed-entries entries) + (map manifest-entry->installed-entry entries)) + +(define (installed-entries-by-name+version name version) + (manifest-entries->installed-entries + (manifest-entries-by-name+version name version))) + +(define (installed-entries-by-package package) + (installed-entries-by-name+version (package-name package) + (package-version package))) + +(define (package-inputs-names inputs) + "Return list of full names of the packages from package INPUTS." + (filter-map (match-lambda + ((_ (? package? package)) + (package-full-name package)) + (_ #f)) + inputs)) + +(define (package-license-names package) + "Return list of license names of the PACKAGE." + (fold-object (lambda (license res) + (if (license? license) + (cons (license-name license) res) + res)) + '() + (package-license package))) + +(define (package-unique? package) + "Return #t if PACKAGE is a single package with such name/version." + (null? (cdr (packages-by-name+version (package-name package) + (package-version package))))) + +(define package-param-alist + (list + (cons 'id object-address) + (cons 'name package-name) + (cons 'version package-version) + (cons 'license package-license-names) + (cons 'synopsis package-synopsis) + (cons 'description package-description) + (cons 'home-url package-home-page) + (cons 'outputs package-outputs) + (cons 'non-unique (negate package-unique?)) + (cons 'inputs (lambda (pkg) (package-inputs-names + (package-inputs pkg)))) + (cons 'native-inputs (lambda (pkg) (package-inputs-names + (package-native-inputs pkg)))) + (cons 'propagated-inputs (lambda (pkg) (package-inputs-names + (package-propagated-inputs pkg)))) + (cons 'location (lambda (pkg) (location->string + (package-location pkg)))) + (cons 'installed installed-entries-by-package))) + +(define (package-param package param) + "Return the value of a PACKAGE PARAM." + (define (accessor param) + (and=> (assq param package-param-alist) + cdr)) + (and=> (accessor param) + (cut <> package))) + +(define (matching-package-entries ->entry predicate) + "Return list of package entries for the matching packages. +PREDICATE is called on each package." + (fold-packages (lambda (pkg res) + (if (predicate pkg) + (cons (->entry pkg) res) + res)) + '())) + +(define (make-obsolete-package-entry name version entries) + "Return package entry for an obsolete package with NAME and VERSION. +ENTRIES is a list of manifest entries used to get installed info." + `((id . ,(name+version->full-name name version)) + (name . ,name) + (version . ,version) + (outputs . ,(map manifest-entry-output entries)) + (obsolete . #t) + (installed . ,(manifest-entries->installed-entries entries)))) + +(define (package-entries-by-name+version ->entry name version) + "Return list of package entries for packages with NAME and VERSION." + (let ((packages (packages-by-name+version name version))) + (if (null? packages) + (let ((entries (manifest-entries-by-name+version name version))) + (if (null? entries) + '() + (list (make-obsolete-package-entry name version entries)))) + (map ->entry packages)))) + +(define (package-entries-by-spec profile ->entry spec) + "Return list of package entries for packages with name specification SPEC." + (set-current-manifest-maybe! profile) + (let-values (((name version) + (full-name->name+version spec))) + (if version + (package-entries-by-name+version ->entry name version) + (matching-package-entries + ->entry + (lambda (pkg) (string=? name (package-name pkg))))))) + +(define (package-entries-by-regexp profile ->entry regexp match-params) + "Return list of package entries for packages matching REGEXP string. +MATCH-PARAMS is a list of parameters that REGEXP can match." + (define (package-match? package regexp) + (any (lambda (param) + (let ((val (package-param package param))) + (and (string? val) (regexp-exec regexp val)))) + match-params)) + + (set-current-manifest-maybe! profile) + (let ((re (make-regexp regexp regexp/icase))) + (matching-package-entries ->entry (cut package-match? <> re)))) + +(define (package-entries-by-ids profile ->entry ids) + "Return list of package entries for packages matching KEYS. +IDS may be an object-address, a full-name or a list of such elements." + (set-current-manifest-maybe! profile) + (fold-object + (lambda (id res) + (if (integer? id) + (let ((pkg (package-by-address id))) + (if pkg + (cons (->entry pkg) res) + res)) + (let ((entries (package-entries-by-spec #f ->entry id))) + (if (null? entries) + res + (append res entries))))) + '() + ids)) + +(define (newest-available-package-entries profile ->entry) + "Return list of package entries for the newest available packages." + (set-current-manifest-maybe! profile) + (vhash-fold (lambda (name elem res) + (match elem + ((version newest pkgs ...) + (cons (->entry newest) res)))) + '() + (find-newest-available-packages))) + +(define (all-available-package-entries profile ->entry) + "Return list of package entries for all available packages." + (set-current-manifest-maybe! profile) + (matching-package-entries ->entry (const #t))) + +(define (manifest-package-entries ->entry) + "Return list of package entries for the current manifest." + (fold-manifest-entries + (lambda (name version entries res) + ;; We don't care about duplicates for the list of + ;; installed packages, so just take any package (car) + ;; matching name+version + (cons (car (package-entries-by-name+version ->entry name version)) + res)) + '())) + +(define (installed-package-entries profile ->entry) + "Return list of package entries for all installed packages." + (set-current-manifest-maybe! profile) + (manifest-package-entries ->entry)) + +(define (generation-package-entries profile ->entry generation) + "Return list of package entries for packages from GENERATION." + (set-current-manifest-maybe! + (generation-file-name profile generation)) + (manifest-package-entries ->entry)) + +(define (obsolete-package-entries profile _) + "Return list of package entries for obsolete packages." + (set-current-manifest-maybe! profile) + (fold-manifest-entries + (lambda (name version entries res) + (let ((packages (packages-by-name+version name version))) + (if (null? packages) + (cons (make-obsolete-package-entry name version entries) res) + res))) + '())) + + +;;; Generation entries + +(define (profile-generations profile) + "Return list of generations for PROFILE." + (let ((generations (generation-numbers profile))) + (if (equal? generations '(0)) + '() + generations))) + +(define (generation-param-alist profile) + "Return alist of generation parameters and functions for PROFILE." + (list + (cons 'id identity) + (cons 'number identity) + (cons 'prev-number (cut previous-generation-number profile <>)) + (cons 'path (cut generation-file-name profile <>)) + (cons 'time (lambda (gen) + (time-second (generation-time profile gen)))))) + +(define (matching-generation-entries profile ->entry predicate) + "Return list of generation entries for the matching generations. +PREDICATE is called on each generation." + (filter-map (lambda (gen) + (and (predicate gen) (->entry gen))) + (profile-generations profile))) + +(define (last-generation-entries profile ->entry number) + "Return list of last NUMBER generation entries. +If NUMBER is 0 or less, return all generation entries." + (let ((generations (profile-generations profile)) + (number (if (<= number 0) +inf.0 number))) + (map ->entry + (if (> (length generations) number) + (list-head (reverse generations) number) + generations)))) + +(define (all-generation-entries profile ->entry) + "Return list of all generation entries." + (last-generation-entries profile ->entry +inf.0)) + +(define (generation-entries-by-ids profile ->entry ids) + "Return list of generation entries for generations matching IDS. +IDS is a list of generation numbers." + (matching-generation-entries profile ->entry (cut memq <> ids))) + + +;;; Getting package/generation entries + +(define %package-entries-functions + (alist->vhash + `((id . ,package-entries-by-ids) + (name . ,package-entries-by-spec) + (regexp . ,package-entries-by-regexp) + (all-available . ,all-available-package-entries) + (newest-available . ,newest-available-package-entries) + (installed . ,installed-package-entries) + (obsolete . ,obsolete-package-entries) + (generation . ,generation-package-entries)) + hashq)) + +(define %generation-entries-functions + (alist->vhash + `((id . ,generation-entries-by-ids) + (last . ,last-generation-entries) + (all . ,all-generation-entries)) + hashq)) + +(define (get-entries profile params entry-type search-type search-vals) + "Return list of entries. +ENTRY-TYPE and SEARCH-TYPE define a search function that should be +applied to PARAMS and VALS." + (let-values (((vhash ->entry) + (case entry-type + ((package) + (values %package-entries-functions + (object-transformer + package-param-alist params))) + ((generation) + (values %generation-entries-functions + (object-transformer + (generation-param-alist profile) params))) + (else (format (current-error-port) + "Wrong entry type '~a'" entry-type))))) + (match (vhash-assq search-type vhash) + ((key . fun) + (apply fun profile ->entry search-vals)) + (_ '())))) + + +;;; Actions + +(define* (package->manifest-entry* package #:optional output) + (and package + (begin + (check-package-freshness package) + (package->manifest-entry package output)))) + +(define* (make-install-manifest-entries id #:optional output) + (package->manifest-entry* (package-by-id id) output)) + +(define* (make-upgrade-manifest-entries id #:optional output) + (package->manifest-entry* (newest-package-by-id id) output)) + +(define* (make-manifest-pattern id #:optional output) + "Make manifest pattern from a package ID and OUTPUT." + (let-values (((name version) + (id->name+version id))) + (and name version + (manifest-pattern + (name name) + (version version) + (output output))))) + +(define (convert-action-pattern pattern proc) + "Convert action PATTERN into a list of objects returned by PROC. +PROC is called: (PROC ID) or (PROC ID OUTPUT)." + (match pattern + ((id . outputs) + (if (null? outputs) + (let ((obj (proc id))) + (if obj (list obj) '())) + (filter-map (cut proc id <>) + outputs))) + (_ '()))) + +(define (convert-action-patterns patterns proc) + (append-map (cut convert-action-pattern <> proc) + patterns)) + +(define* (process-package-actions + profile #:key (install '()) (upgrade '()) (remove '()) + (use-substitutes? #t) dry-run?) + "Perform package actions. + +INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'. +Each pattern should have the following form: + + (ID . OUTPUTS) + +ID is an object address or a full-name of a package. +OUTPUTS is a list of package outputs (may be an empty list)." + (format #t "The process begins ...~%") + (let* ((install (append + (convert-action-patterns + install make-install-manifest-entries) + (convert-action-patterns + upgrade make-upgrade-manifest-entries))) + (remove (convert-action-patterns remove make-manifest-pattern)) + (transaction (manifest-transaction (install install) + (remove remove))) + (manifest (profile-manifest profile)) + (new-manifest (manifest-perform-transaction + manifest transaction))) + (unless (and (null? install) (null? remove)) + (let* ((store (open-connection)) + (derivation (run-with-store + store (profile-derivation new-manifest))) + (derivations (list derivation)) + (new-profile (derivation->output-path derivation))) + (set-build-options store + #:use-substitutes? use-substitutes?) + (manifest-show-transaction store manifest transaction + #:dry-run? dry-run?) + (show-what-to-build store derivations + #:use-substitutes? use-substitutes? + #:dry-run? dry-run?) + (unless dry-run? + (let ((name (generation-file-name + profile + (+ 1 (generation-number profile))))) + (and (build-derivations store derivations) + (let* ((entries (manifest-entries new-manifest)) + (count (length entries))) + (switch-symlinks name new-profile) + (switch-symlinks profile name) + (format #t (N_ "~a package in profile~%" + "~a packages in profile~%" + count) + count))))))))) + |