>From d42829fe03271e633e43cc35cf277705203e6080 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Thu, 18 Sep 2014 16:24:02 +0400 Subject: [PATCH 2/3] emacs: Rewrite scheme side in a functional manner. * emacs/guix-main.scm: Rewrite in a functional way. Add support for output entries. (%current-manifest, %current-manifest-entries-table, set-current-manifest-maybe!): Replace with... (mentries->hash-table, manifest->hash-table): ... this. (manifest-entries-by-name+version): Replace with... (mentries-by-name): ... this. (fold-manifest-entries): Rename to... (fold-manifest-by-name): ... this. (package-installed-param-alist): Rename to... (%mentry-param-alist): ... this. (package-param-alist): Rename to... (%package-param-alist): this. (manifest-entry->installed-entry): Rename to... (mentry->alist): ... this. (matching-generation-entries): Replace with... (matching-generations): ... this. (last-generation-entries): Replace with... (last-generations): ... this. (manifest-entries->installed-entries, installed-entries-by-name+version, installed-entries-by-package, matching-package-entries, fold-object, package-entries-by-name+version, package-entries-by-spec, package-entries-by-regexp, package-entries-by-ids, newest-available-package-entries, all-available-package-entries, manifest-package-entries, installed-package-entries, generation-package-entries, obsolete-package-entries, all-generation-entries, generation-entries-by-ids, %package-entries-functions, %generation-entries-functions): Remove. (manifest=?, mentry->name+version+output, mentry-by-output, list-maybe, matching-packages, filter-packages-by-output, packages-by-name, mentry->packages, all-available-packages, newest-available-packages, spec->package-pattern, spec->output-pattern, id->package-pattern, id->output-pattern, specs->package-patterns, specs->output-patterns, ids->package-patterns, ids->output-patterns, obsolete-package-patterns, obsolete-output-patterns, manifest-package-patterns, manifest-output-patterns, make-installed-alists, make-package-entry, make-output-entry, make-obsolete-output-entry, package-pattern-transformer, output-pattern-transformer, entry-type-error, search-type-error, pattern-transformer, patterns-maker, get-package/output-entries, find-generations, get-generation-entries): New procedures. (%pattern-transformers, %patterns-makers): New variables. (get-entries): Use 'get-package/output-entries', 'get-generation-entries'. * emacs/guix-base.el (guix-continue-package-operation-p): Adjust accordingly. * emacs/guix-info.el (guix-package-info-insert-action-button): Likewise. --- emacs/guix-base.el | 6 +- emacs/guix-info.el | 3 +- emacs/guix-main.scm | 772 ++++++++++++++++++++++++++++++++-------------------- 3 files changed, 480 insertions(+), 301 deletions(-) diff --git a/emacs/guix-base.el b/emacs/guix-base.el index d4ac643..1959814 100644 --- a/emacs/guix-base.el +++ b/emacs/guix-base.el @@ -563,9 +563,9 @@ See `guix-process-package-actions' for details." (or (null guix-operation-confirm) (let* ((entries (guix-get-entries 'package 'id - (list (append (mapcar #'car install) - (mapcar #'car upgrade) - (mapcar #'car remove))) + (append (mapcar #'car install) + (mapcar #'car upgrade) + (mapcar #'car remove)) '(id name version location))) (install-strings (guix-get-package-strings install entries)) (upgrade-strings (guix-get-package-strings upgrade entries)) diff --git a/emacs/guix-info.el b/emacs/guix-info.el index e7fc7f0..05281e7 100644 --- a/emacs/guix-info.el +++ b/emacs/guix-info.el @@ -512,7 +512,8 @@ ENTRY is an alist with package info." (button-get btn 'output))))) (concat type-str " '" full-name "'") 'action-type type - 'id (guix-get-key-val entry 'id) + 'id (or (guix-get-key-val entry 'package-id) + (guix-get-key-val entry 'id)) 'output output))) (defun guix-package-info-insert-output-path (path &optional _) diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm index 1383d08..9295894 100644 --- a/emacs/guix-main.scm +++ b/emacs/guix-main.scm @@ -24,11 +24,12 @@ ;; 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’). +;; ‘%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 :) +;; "entry" described above. Do not be confused. "Manifest entries" are +;; shortened to "mentries" in this file. ;; ‘get-entries’ function is the “entry point” for the elisp side to get ;; information about packages and generations. @@ -46,7 +47,7 @@ ;; ;; ‘installed’ parameter of a package entry contains information about ;; installed outputs. It is a list of "installed entries" (see -;; ‘package-installed-param-alist’). +;; ‘%mentry-param-alist’). ;; To speed-up the process of getting information, the following ;; auxiliary variables are used: @@ -55,10 +56,6 @@ ;; ;; - `%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: @@ -97,9 +94,6 @@ (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)) @@ -119,90 +113,74 @@ %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 (mentry->name+version+output mentry) + (values + (manifest-entry-name mentry) + (manifest-entry-version mentry) + (manifest-entry-output mentry))) + +(define (mentries->hash-table mentries) + "Return hash table of name keys and lists of matching MENTRIES." + (let ((table (make-hash-table (length mentries)))) + (for-each (lambda (mentry) + (let* ((key (manifest-entry-name mentry)) + (ref (hash-ref table key))) + (hash-set! table key + (if ref (cons mentry ref) (list mentry))))) + mentries) + table)) -(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))) +(define (manifest=? m1 m2) + (or (eq? m1 m2) + (equal? m1 m2))) + +(define manifest->hash-table + (let ((current-manifest #f) + (current-table #f)) + (lambda (manifest) + "Return hash table of name keys and lists of matching MANIFEST entries." + (unless (manifest=? manifest current-manifest) + (set! current-manifest manifest) + (set! current-table (mentries->hash-table + (manifest-entries manifest)))) + current-table))) + +(define* (mentries-by-name manifest name #:optional version output) + "Return list of MANIFEST entries matching NAME, VERSION and OUTPUT." + (let ((mentries (or (hash-ref (manifest->hash-table manifest) name) + '()))) + (if (or version output) + (filter (lambda (mentry) + (and (or (not version) + (equal? version (manifest-entry-version mentry))) + (or (not output) + (equal? output (manifest-entry-output mentry))))) + mentries) + mentries))) + +(define (mentry-by-output mentries output) + (find (lambda (mentry) + (string= output (manifest-entry-output mentry))) + mentries)) + +(define (fold-manifest-by-name manifest proc init) + "Fold over MANIFEST entries. +Call (PROC NAME VERSION MENTRIES RESULT), using INIT as the initial value +of RESULT. MENTRIES is a list of manifest entries with NAME/VERSION." + (hash-fold (lambda (name mentries res) + (proc name (manifest-entry-version (car mentries)) + mentries res)) init - %current-manifest-entries-table)) + (manifest->hash-table manifest))) -(define (fold-object proc init obj) - (fold proc init - (if (list? obj) obj (list obj)))) +(define (list-maybe obj) + (if (list? obj) obj (list obj))) (define* (object-transformer param-alist #:optional (params '())) - "Return function for transforming an object into alist of parameters/values. + "Return function for transforming objects 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. +PARAM-ALIST is alist of available parameters (symbols) and functions returning +values of these parameters. Each function is applied to objects. 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 @@ -224,31 +202,19 @@ Example: (cons param fun))) (_ #f)) param-alist)))) - (lambda (object) + (lambda objects (map (match-lambda ((param . fun) - (cons param (fun object)))) + (cons param (apply fun objects)))) 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 %mentry-param-alist + `((output . ,manifest-entry-output) + (path . ,manifest-entry-item) + (dependencies . ,manifest-entry-dependencies))) -(define (installed-entries-by-package package) - (installed-entries-by-name+version (package-name package) - (package-version package))) +(define mentry->alist + (object-transformer %mentry-param-alist)) (define (package-inputs-names inputs) "Return list of full names of the packages from package INPUTS." @@ -260,89 +226,112 @@ Example: (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))) + (filter-map (lambda (license) + (and (license? license) + (license-name license))) + (list-maybe (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))) + (null? (cdr (packages-by-name (package-name package) + (package-version package))))) + +(define %package-param-alist + `((id . ,object-address) + (package-id . ,object-address) + (name . ,package-name) + (version . ,package-version) + (license . ,package-license-names) + (synopsis . ,package-synopsis) + (description . ,package-description) + (home-url . ,package-home-page) + (outputs . ,package-outputs) + (non-unique . ,(negate package-unique?)) + (inputs . ,(lambda (pkg) + (package-inputs-names + (package-inputs pkg)))) + (native-inputs . ,(lambda (pkg) + (package-inputs-names + (package-native-inputs pkg)))) + (propagated-inputs . ,(lambda (pkg) + (package-inputs-names + (package-propagated-inputs pkg)))) + (location . ,(lambda (pkg) + (location->string (package-location pkg)))))) (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) + (and=> (assq-ref %package-param-alist param) (cut <> package))) -(define (matching-package-entries ->entry predicate) - "Return list of package entries for the matching packages. -PREDICATE is called on each package." + +;;; Finding packages + +(define (package-by-address address) + (and=> (vhash-assq address %packages) + cdr)) + +(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 (packages-by-id id) + (if (integer? id) + (let ((pkg (package-by-address id))) + (if pkg (list pkg) '())) + (packages-by-full-name id))) + +(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 (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 (matching-packages predicate) (fold-packages (lambda (pkg res) (if (predicate pkg) - (cons (->entry pkg) res) + (cons 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 (filter-packages-by-output packages output) + (filter (lambda (package) + (member output (package-outputs package))) + packages)) + +(define* (packages-by-name name #:optional version output) + "Return list of packages matching NAME, VERSION and OUTPUT." + (let ((packages (if version + (packages-by-name+version name version) + (matching-packages + (lambda (pkg) (string=? name (package-name pkg))))))) + (if output + (filter-packages-by-output packages output) + 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 (mentry->packages mentry) + (call-with-values + (lambda () (mentry->name+version+output mentry)) + packages-by-name)) -(define (package-entries-by-regexp profile ->entry regexp match-params) - "Return list of package entries for packages matching REGEXP string. +(define (packages-by-regexp regexp match-params) + "Return list of packages matching REGEXP string. MATCH-PARAMS is a list of parameters that REGEXP can match." (define (package-match? package regexp) (any (lambda (param) @@ -350,81 +339,297 @@ MATCH-PARAMS is a list of parameters that REGEXP can match." (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) + (matching-packages (cut package-match? <> re)))) + +(define (all-available-packages) + "Return list of all available packages." + (matching-packages (const #t))) + +(define (newest-available-packages) + "Return list of the newest available packages." (vhash-fold (lambda (name elem res) (match elem - ((version newest pkgs ...) - (cons (->entry newest) res)))) + ((_ newest pkgs ...) + (cons 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))) + +;;; Making package/output patterns -(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 (spec->package-pattern spec) + (call-with-values + (lambda () (full-name->name+version spec)) + list)) + +(define (spec->output-pattern spec) + (call-with-values + (lambda () (package-specification->name+version+output spec #f)) + list)) + +(define (id->package-pattern id) + (if (integer? id) + (package-by-address id) + (spec->package-pattern id))) + +(define (id->output-pattern id) + ;; id should be ":" or "-:" + (let-values (((name version output) + (package-specification->name+version+output id))) + (if version + (list name version output) + (list (package-by-address (string->number name)) + output)))) + +(define (specs->package-patterns . specs) + (map spec->package-pattern specs)) + +(define (specs->output-patterns . specs) + (map spec->output-pattern specs)) + +(define (ids->package-patterns . ids) + (map id->package-pattern ids)) -(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 +(define (ids->output-patterns . ids) + (map id->output-pattern ids)) + +(define (obsolete-package-patterns manifest) + "Return list of package patterns for obsolete packages." + (fold-manifest-by-name + manifest (lambda (name version entries res) - (let ((packages (packages-by-name+version name version))) + (let ((packages (packages-by-name name version))) (if (null? packages) - (cons (make-obsolete-package-entry name version entries) res) + (cons (list name version entries '()) res) res))) '())) +(define (obsolete-output-patterns manifest) + "Return list of output patterns for obsolete packages." + (fold (lambda (mentry res) + (let ((packages (mentry->packages mentry))) + (if (null? packages) + (cons (list mentry '()) res) + res))) + '() + (manifest-entries manifest))) + +(define (manifest-package-patterns manifest) + "Return list of package patterns for all MANIFEST entries." + (fold-manifest-by-name manifest + (lambda (name version mentries res) + (cons (list name version mentries) res)) + '())) + +(define manifest-output-patterns manifest-entries) + + +;;; Transforming package/output patterns into entries + +(define (make-installed-alists mentries) + (map mentry->alist mentries)) + +(define (make-package-entry palist malists) + (cons (cons 'installed malists) + palist)) + +(define (make-obsolete-package-entry name version mentries) + `((id . ,(name+version->full-name name version)) + (name . ,name) + (version . ,version) + (outputs . ,(map manifest-entry-output mentries)) + (obsolete . #t) + (installed . ,(make-installed-alists mentries)))) + +(define* (make-output-entry palist package-address output + #:optional (malist '()) #:key installed?) + (let ((base `((id . ,(string-append + (number->string package-address) + ":" output)) + (output . ,output) + (installed . ,installed?)))) + (append base malist palist))) + +(define* (make-obsolete-output-entry name version output + #:optional (malist '())) + (let ((base `((id . ,(make-package-specification + name version output)) + (package-id . ,(name+version->full-name name version)) + (name . ,name) + (version . ,version) + (output . ,output) + (obsolete . #t) + (installed . #t)))) + (append malist base))) + +(define (package-pattern-transformer manifest params) + "Return 'package-pattern->package-entries' function." + (define package->alist + (object-transformer %package-param-alist params)) + + (define (->entries pattern) + (match pattern + ((? package? package) + (list (make-package-entry + (package->alist package) + (make-installed-alists + (mentries-by-name manifest + (package-name package) + (package-version package)))))) + ((name version) + (->entries (list name version + (mentries-by-name manifest name version)))) + ((name version mentries) + (->entries (list name version mentries + (packages-by-name name version)))) + ((name version mentries packages) + (if (null? packages) + (if (null? mentries) + '() + (list (make-obsolete-package-entry + name version mentries))) + (let ((malists (make-installed-alists mentries))) + (map (lambda (package) + (make-package-entry (package->alist package) + malists)) + packages)))))) + + ->entries) + +(define (output-pattern-transformer manifest params) + "Return 'output-pattern->output-entries' function." + (define package->alist + (object-transformer (alist-delete 'id %package-param-alist) + params)) + + (define mentry->alist + (object-transformer (alist-delete 'output %mentry-param-alist) + params)) + + (define* (entries-by-package package #:optional output + (mentries (mentries-by-name + manifest + (package-name package) + (package-version package)))) + ;; Assuming that PACKAGE has this OUTPUT. + (let ((palist (package->alist package)) + (address (object-address package)) + (outputs (if output + (list output) + (package-outputs package)))) + (map (lambda (output) + (let* ((mentry (mentry-by-output mentries output)) + (malist (if mentry (mentry->alist mentry) '()))) + (make-output-entry palist address output malist + #:installed? (->bool mentry)))) + outputs))) + + (define* (entries-by-mentry mentry #:optional + (packages (mentry->packages mentry))) + (let-values (((name version output) + (mentry->name+version+output mentry))) + (let ((malist (mentry->alist mentry))) + (if (null? packages) + (list (make-obsolete-output-entry + name version output malist)) + (map (lambda (package) + (make-output-entry + (package->alist package) + (object-address package) + output malist #:installed? #t)) + packages))))) + + (define (->entries pattern) + (match pattern + ((? package? package) + (entries-by-package package)) + (((? package? package) output) + (entries-by-package package output)) + ((? manifest-entry? mentry) + (entries-by-mentry mentry)) + (((? manifest-entry? mentry) packages) + (entries-by-mentry mentry packages)) + ((name version output) + (let ((packages (packages-by-name name version output)) + (mentries (mentries-by-name manifest name version output))) + (if (null? mentries) + (append-map (cut entries-by-package <> output mentries) + packages) + (append-map (cut entries-by-mentry <> packages) + mentries)))))) + + ->entries) + +(define (entry-type-error entry-type) + (error (format #f "Wrong entry-type '~a'" entry-type))) + +(define (search-type-error entry-type search-type) + (error (format #f "Wrong search type '~a' for entry-type '~a'" + search-type entry-type))) + +(define %pattern-transformers + `((package . ,package-pattern-transformer) + (output . ,output-pattern-transformer))) + +(define (pattern-transformer entry-type) + (assq-ref %pattern-transformers entry-type)) + +;; All functions from inner alists are called with (MANIFEST . SEARCH-VALS) as +;; arguments; see `get-package/output-entries'. +(define %patterns-makers + (let* ((apply-to-rest (lambda (fun) + (lambda (_ . rest) (apply fun rest)))) + (apply-to-first (lambda (fun) + (lambda (first . _) (fun first)))) + (manifest-package-fun (apply-to-first manifest-package-patterns)) + (manifest-output-fun (apply-to-first manifest-output-patterns)) + (regexp-fun (lambda (_ regexp params . __) + (packages-by-regexp regexp params))) + (all-fun (lambda _ (all-available-packages))) + (newest-fun (lambda _ (newest-available-packages)))) + `((package + (id . ,(apply-to-rest ids->package-patterns)) + (name . ,(apply-to-rest specs->package-patterns)) + (installed . ,manifest-package-fun) + (generation . ,manifest-package-fun) + (obsolete . ,(apply-to-first obsolete-package-patterns)) + (regexp . ,regexp-fun) + (all-available . ,all-fun) + (newest-available . ,newest-fun)) + (output + (id . ,(apply-to-rest ids->output-patterns)) + (name . ,(apply-to-rest specs->output-patterns)) + (installed . ,manifest-output-fun) + (generation . ,manifest-output-fun) + (obsolete . ,(apply-to-first obsolete-output-patterns)) + (regexp . ,regexp-fun) + (all-available . ,all-fun) + (newest-available . ,newest-fun))))) + +(define (patterns-maker entry-type search-type) + (or (and=> (assq-ref %patterns-makers entry-type) + (cut assq-ref <> search-type)) + (search-type-error entry-type search-type))) + +(define (get-package/output-entries profile params entry-type + search-type search-vals) + "Return list of package or output entries." + (let* ((profile (if (eq? search-type 'generation) + (generation-file-name profile (car search-vals)) + profile)) + (manifest (profile-manifest profile)) + (patterns (apply (patterns-maker entry-type search-type) + manifest search-vals)) + (->entries ((pattern-transformer entry-type) manifest params))) + (append-map ->entries patterns))) + ;;; Generation entries +;;; XXX move to (guix profiles) ? (define (profile-generations profile) - "Return list of generations for PROFILE." + "Return list of PROFILE generations." (let ((generations (generation-numbers profile))) (if (equal? generations '(0)) '() @@ -440,74 +645,48 @@ IDS may be an object-address, a full-name or a list of such elements." (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 (matching-generations profile predicate) + "Return list of PROFILE generations matching PREDICATE." + (filter predicate (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." +(define (last-generations profile number) + "Return list of last NUMBER generations. +If NUMBER is 0 or less, return all generations." (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)) + (if (> (length generations) number) + (list-head (reverse generations) number) + generations))) -(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))) +(define (find-generations profile search-type search-vals) + (case search-type + ((id) + (matching-generations profile (cut memq <> (car search-vals)))) + ((last) + (last-generations profile (car search-vals))) + ((all) + (last-generations profile +inf.0)) + (else (search-type-error "generation" search-type)))) + +(define (get-generation-entries profile params search-type search-vals) + "Return list of generation entries." + (let ((generations (find-generations profile search-type search-vals)) + (->entry (object-transformer (generation-param-alist profile) + params))) + (map ->entry generations))) -;;; 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)) +;;; Getting package/output/generation entries (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)) - (_ '())))) + (case entry-type + ((package output) + (get-package/output-entries profile params entry-type + search-type search-vals)) + ((generation) + (get-generation-entries profile params + search-type search-vals)) + (else (entry-type-error entry-type)))) ;;; Actions @@ -592,12 +771,11 @@ OUTPUTS is a list of package outputs (may be an empty list)." profile (+ 1 (generation-number profile))))) (and (build-derivations store derivations) - (let* ((entries (manifest-entries new-manifest)) - (count (length entries))) + (let* ((mentries (manifest-entries new-manifest)) + (count (length mentries))) (switch-symlinks name new-profile) (switch-symlinks profile name) (format #t (N_ "~a package in profile~%" "~a packages in profile~%" count) count))))))))) - -- 2.1.0