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...
  (manifest-entries->hash-table, manifest->hash-table): ... this.
  (manifest-entries-by-name+version): Replace with...
  (manifest-entries-by-name): ... this.
  (fold-manifest-entries): Rename to...
  (fold-manifest-by-name): ... this.
  (package-installed-param-alist): Rename to...
  (%manifest-entry-param-alist): ... this.
  (package-param-alist): Rename to...
  (%package-param-alist): this.
  (manifest-entry->installed-entry): Rename to...
  (manifest-entry->sexp): ... this.
  (manifest-entries->installed-entries): Rename to...
  (manifest-entries->sexps): ... this.
  (matching-generation-entries): Replace with...
  (matching-generations): ... this.
  (last-generation-entries): Replace with...
  (last-generations): ... this.
  (get-entries): Rename to...
  (entries): ... this.
  (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, profile-generations,
  %package-entries-functions, %generation-entries-functions): Remove.
  (manifest=?, manifest-entry->name+version+output, manifest-entry-by-output,
  list-maybe, matching-packages, filter-packages-by-output, packages-by-name,
  manifest-entry->packages, all-available-packages, newest-available-packages,
  specification->package-pattern, specification->output-pattern,
  id->package-pattern, id->output-pattern, specifications->package-patterns,
  specifications->output-patterns, ids->package-patterns,
  ids->output-patterns, manifest-patterns-result, obsolete-package-patterns,
  obsolete-output-patterns, manifest-package-patterns,
  manifest-output-patterns, obsolete-package-sexp,
  package-pattern-transformer, output-pattern-transformer, entry-type-error,
  search-type-error, pattern-transformer, patterns-maker,
  package/output-sexps, find-generations, generation-sexps): New procedures.
  (%pattern-transformers, %patterns-makers): New variables.
* emacs/guix-base.el (guix-continue-package-operation-p): Adjust accordingly.
* emacs/guix-info.el (guix-package-info-insert-action-button): Likewise.
This commit is contained in:
Alex Kost 2014-09-18 16:24:02 +04:00
parent dfeb023927
commit 81b339fe31
3 changed files with 550 additions and 337 deletions

View File

@ -323,8 +323,8 @@ following keywords are available:
Call an appropriate scheme function and return a list of the Call an appropriate scheme function and return a list of the
form of `guix-entries'. form of `guix-entries'.
ENTRY-TYPE should be one of the following symbols: `package' or ENTRY-TYPE should be one of the following symbols: `package',
`generation'. `output' or `generation'.
SEARCH-TYPE may be one of the following symbols: SEARCH-TYPE may be one of the following symbols:
@ -337,7 +337,7 @@ SEARCH-TYPE may be one of the following symbols:
PARAMS is a list of parameters for receiving. If nil, get PARAMS is a list of parameters for receiving. If nil, get
information with all available parameters." information with all available parameters."
(guix-eval-read (guix-make-guile-expression (guix-eval-read (guix-make-guile-expression
'get-entries 'entries
guix-current-profile params guix-current-profile params
entry-type search-type search-vals))) entry-type search-type search-vals)))
@ -563,9 +563,9 @@ See `guix-process-package-actions' for details."
(or (null guix-operation-confirm) (or (null guix-operation-confirm)
(let* ((entries (guix-get-entries (let* ((entries (guix-get-entries
'package 'id 'package 'id
(list (append (mapcar #'car install) (append (mapcar #'car install)
(mapcar #'car upgrade) (mapcar #'car upgrade)
(mapcar #'car remove))) (mapcar #'car remove))
'(id name version location))) '(id name version location)))
(install-strings (guix-get-package-strings install entries)) (install-strings (guix-get-package-strings install entries))
(upgrade-strings (guix-get-package-strings upgrade entries)) (upgrade-strings (guix-get-package-strings upgrade entries))

View File

@ -512,7 +512,8 @@ ENTRY is an alist with package info."
(button-get btn 'output))))) (button-get btn 'output)))))
(concat type-str " '" full-name "'") (concat type-str " '" full-name "'")
'action-type type '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))) 'output output)))
(defun guix-package-info-insert-output-path (path &optional _) (defun guix-package-info-insert-output-path (path &optional _)

View File

@ -20,17 +20,9 @@
;; Information about packages and generations is passed to the elisp ;; Information about packages and generations is passed to the elisp
;; side in the form of alists of parameters (such as name or ;; side in the form of alists of parameters (such as name or
;; version) and their values. These alists are called "entries" in ;; version) and their values.
;; 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 ;; entries procedure is the “entry point” for the elisp side to get
;; information about packages and generations. ;; information about packages and generations.
;; Since name/version pair is not necessarily unique, we use ;; Since name/version pair is not necessarily unique, we use
@ -43,10 +35,6 @@
;; Important: as object addresses live only during guile session, elisp ;; Important: as object addresses live only during guile session, elisp
;; part should take care about updating information after "Guix REPL" is ;; part should take care about updating information after "Guix REPL" is
;; restarted (TODO!) ;; 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 ;; To speed-up the process of getting information, the following
;; auxiliary variables are used: ;; auxiliary variables are used:
@ -55,10 +43,6 @@
;; ;;
;; - `%package-table' - Hash table of ;; - `%package-table' - Hash table of
;; "name+version key"/"list of packages" pairs. ;; "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: ;;; Code:
@ -82,6 +66,9 @@
(and (not (null? lst)) (and (not (null? lst))
(first lst))) (first lst)))
(define (list-maybe obj)
(if (list? obj) obj (list obj)))
(define full-name->name+version package-name->name+version) (define full-name->name+version package-name->name+version)
(define (name+version->full-name name version) (define (name+version->full-name name version)
(string-append name "-" version)) (string-append name "-" version))
@ -97,9 +84,6 @@
(define name+version->key cons) (define name+version->key cons)
(define key->name+version car+cdr) (define key->name+version car+cdr)
(define %current-manifest #f)
(define %current-manifest-entries-table #f)
(define %packages (define %packages
(fold-packages (lambda (pkg res) (fold-packages (lambda (pkg res)
(vhash-consq (object-address pkg) pkg res)) (vhash-consq (object-address pkg) pkg res))
@ -119,33 +103,165 @@
%packages) %packages)
table)) table))
;; FIXME get rid of this function! (define (manifest-entry->name+version+output entry)
(define (set-current-manifest-maybe! profile) (values
(define (manifest-entries->hash-table entries) (manifest-entry-name entry)
(let ((entries-table (make-hash-table (length entries)))) (manifest-entry-version entry)
(for-each (lambda (entry) (manifest-entry-output entry)))
(let* ((key (name+version->key
(manifest-entry-name entry) (define (manifest-entries->hash-table entries)
(manifest-entry-version entry))) "Return a hash table of name keys and lists of matching manifest ENTRIES."
(ref (hash-ref entries-table key))) (let ((table (make-hash-table (length entries))))
(hash-set! entries-table key (for-each (lambda (entry)
(if ref (cons entry ref) (list entry))))) (let* ((key (manifest-entry-name entry))
(ref (hash-ref table key)))
(hash-set! table key
(if ref (cons entry ref) (list entry)))))
entries)
table))
(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 a hash table of name keys and matching MANIFEST entries."
(unless (manifest=? manifest current-manifest)
(set! current-manifest manifest)
(set! current-table (manifest-entries->hash-table
(manifest-entries manifest))))
current-table)))
(define* (manifest-entries-by-name manifest name #:optional version output)
"Return a list of MANIFEST entries matching NAME, VERSION and OUTPUT."
(let ((entries (or (hash-ref (manifest->hash-table manifest) name)
'())))
(if (or version output)
(filter (lambda (entry)
(and (or (not version)
(equal? version (manifest-entry-version entry)))
(or (not output)
(equal? output (manifest-entry-output entry)))))
entries) entries)
entries-table)) entries)))
(when profile (define (manifest-entry-by-output entries output)
(let ((manifest (profile-manifest profile))) "Return a manifest entry from ENTRIES matching OUTPUT."
(unless (and (manifest? %current-manifest) (find (lambda (entry)
(equal? manifest %current-manifest)) (string= output (manifest-entry-output entry)))
(set! %current-manifest manifest) entries))
(set! %current-manifest-entries-table
(manifest-entries->hash-table
(manifest-entries manifest)))))))
(define (manifest-entries-by-name+version name version) (define (fold-manifest-by-name manifest proc init)
(or (hash-ref %current-manifest-entries-table "Fold over MANIFEST entries.
(name+version->key name version)) Call (PROC NAME VERSION ENTRIES RESULT), using INIT as the initial value
'())) of RESULT. ENTRIES is a list of manifest entries with NAME/VERSION."
(hash-fold (lambda (name entries res)
(proc name (manifest-entry-version (car entries))
entries res))
init
(manifest->hash-table manifest)))
(define* (object-transformer param-alist #:optional (params '()))
"Return procedure transforming objects into alist of parameter/value pairs.
PARAM-ALIST is alist of available parameters (symbols) and procedures
returning values of these parameters. Each procedure is applied to
objects.
PARAMS is list of parameters from PARAM-ALIST that should be returned by
a resulting procedure. 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* ((use-all-params (null? params))
(alist (filter-map (match-lambda
((param . proc)
(and (or use-all-params
(memq param params))
(cons param proc)))
(_ #f))
param-alist)))
(lambda objects
(map (match-lambda
((param . proc)
(cons param (apply proc objects))))
alist))))
(define %manifest-entry-param-alist
`((output . ,manifest-entry-output)
(path . ,manifest-entry-item)
(dependencies . ,manifest-entry-dependencies)))
(define manifest-entry->sexp
(object-transformer %manifest-entry-param-alist))
(define (manifest-entries->sexps entries)
(map manifest-entry->sexp entries))
(define (package-inputs-names inputs)
"Return a 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 a list of license names of the 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 (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 a value of a PACKAGE PARAM."
(and=> (assq-ref %package-param-alist param)
(cut <> package)))
;;; Finding packages.
(define (package-by-address address)
(and=> (vhash-assq address %packages)
cdr))
(define (packages-by-name+version name version) (define (packages-by-name+version name version)
(or (hash-ref %package-table (or (hash-ref %package-table
@ -157,24 +273,12 @@
(lambda () (full-name->name+version full-name)) (lambda () (full-name->name+version full-name))
packages-by-name+version)) packages-by-name+version))
(define (package-by-address address)
(and=> (vhash-assq address %packages)
cdr))
(define (packages-by-id id) (define (packages-by-id id)
(if (integer? id) (if (integer? id)
(let ((pkg (package-by-address id))) (let ((pkg (package-by-address id)))
(if pkg (list pkg) '())) (if pkg (list pkg) '()))
(packages-by-full-name id))) (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) (define (id->name+version id)
(if (integer? id) (if (integer? id)
(and=> (package-by-address id) (and=> (package-by-address id)
@ -183,166 +287,43 @@
(package-version pkg)))) (package-version pkg))))
(full-name->name+version id))) (full-name->name+version id)))
(define (fold-manifest-entries proc init) (define (package-by-id id)
"Fold over `%current-manifest-entries-table'. (first-or-false (packages-by-id id)))
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) (define (newest-package-by-id id)
(fold proc init (and=> (id->name+version id)
(if (list? obj) obj (list obj)))) (lambda (name)
(first-or-false (find-best-packages-by-name name #f)))))
(define* (object-transformer param-alist #:optional (params '())) (define (matching-packages predicate)
"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) (fold-packages (lambda (pkg res)
(if (predicate pkg) (if (predicate pkg)
(cons (->entry pkg) res) (cons pkg res)
res)) res))
'())) '()))
(define (make-obsolete-package-entry name version entries) (define (filter-packages-by-output packages output)
"Return package entry for an obsolete package with NAME and VERSION. (filter (lambda (package)
ENTRIES is a list of manifest entries used to get installed info." (member output (package-outputs package)))
`((id . ,(name+version->full-name name version)) packages))
(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) (define* (packages-by-name name #:optional version output)
"Return list of package entries for packages with NAME and VERSION." "Return a list of packages matching NAME, VERSION and OUTPUT."
(let ((packages (packages-by-name+version name version))) (let ((packages (if version
(if (null? packages) (packages-by-name+version name version)
(let ((entries (manifest-entries-by-name+version name version))) (matching-packages
(if (null? entries) (lambda (pkg) (string=? name (package-name pkg)))))))
'() (if output
(list (make-obsolete-package-entry name version entries)))) (filter-packages-by-output packages output)
(map ->entry packages)))) packages)))
(define (package-entries-by-spec profile ->entry spec) (define (manifest-entry->packages entry)
"Return list of package entries for packages with name specification SPEC." (call-with-values
(set-current-manifest-maybe! profile) (lambda () (manifest-entry->name+version+output entry))
(let-values (((name version) packages-by-name))
(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) (define (packages-by-regexp regexp match-params)
"Return list of package entries for packages matching REGEXP string. "Return a list of packages matching REGEXP string.
MATCH-PARAMS is a list of parameters that REGEXP can match." MATCH-PARAMS is a list of parameters that REGEXP can match."
(define (package-match? package regexp) (define (package-match? package regexp)
(any (lambda (param) (any (lambda (param)
@ -350,88 +331,311 @@ MATCH-PARAMS is a list of parameters that REGEXP can match."
(and (string? val) (regexp-exec regexp val)))) (and (string? val) (regexp-exec regexp val))))
match-params)) match-params))
(set-current-manifest-maybe! profile)
(let ((re (make-regexp regexp regexp/icase))) (let ((re (make-regexp regexp regexp/icase)))
(matching-package-entries ->entry (cut package-match? <> re)))) (matching-packages (cut package-match? <> re))))
(define (package-entries-by-ids profile ->entry ids) (define (all-available-packages)
"Return list of package entries for packages matching KEYS. "Return a list of all available packages."
IDS may be an object-address, a full-name or a list of such elements." (matching-packages (const #t)))
(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) (define (newest-available-packages)
"Return list of package entries for the newest available packages." "Return a list of the newest available packages."
(set-current-manifest-maybe! profile)
(vhash-fold (lambda (name elem res) (vhash-fold (lambda (name elem res)
(match elem (match elem
((version newest pkgs ...) ((_ newest pkgs ...)
(cons (->entry newest) res)))) (cons newest res))))
'() '()
(find-newest-available-packages))) (find-newest-available-packages)))
(define (all-available-package-entries profile ->entry)
"Return list of package entries for all available packages." ;;; Making package/output patterns.
(set-current-manifest-maybe! profile)
(matching-package-entries ->entry (const #t)))
(define (manifest-package-entries ->entry) (define (specification->package-pattern specification)
"Return list of package entries for the current manifest." (call-with-values
(fold-manifest-entries (lambda ()
(full-name->name+version specification))
list))
(define (specification->output-pattern specification)
(call-with-values
(lambda ()
(package-specification->name+version+output specification #f))
list))
(define (id->package-pattern id)
(if (integer? id)
(package-by-address id)
(specification->package-pattern id)))
(define (id->output-pattern id)
"Return an output pattern by output ID.
ID should be '<package-address>:<output>' or '<name>-<version>:<output>'."
(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 (specifications->package-patterns . specifications)
(map specification->package-pattern specifications))
(define (specifications->output-patterns . specifications)
(map specification->output-pattern specifications))
(define (ids->package-patterns . ids)
(map id->package-pattern ids))
(define (ids->output-patterns . ids)
(map id->output-pattern ids))
(define* (manifest-patterns-result packages res obsolete-pattern
#:optional installed-pattern)
"Auxiliary procedure for 'manifest-package-patterns' and
'manifest-output-patterns'."
(if (null? packages)
(cons (obsolete-pattern) res)
(if installed-pattern
;; We don't need duplicates for a list of installed packages,
;; so just take any (car) package.
(cons (installed-pattern (car packages)) res)
res)))
(define* (manifest-package-patterns manifest #:optional obsolete-only?)
"Return a list of package patterns for MANIFEST entries.
If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only
for obsolete packages."
(fold-manifest-by-name
manifest
(lambda (name version entries res) (lambda (name version entries res)
;; We don't care about duplicates for the list of (manifest-patterns-result (packages-by-name name version)
;; installed packages, so just take any package (car) res
;; matching name+version (lambda () (list name version entries))
(cons (car (package-entries-by-name+version ->entry name version)) (and (not obsolete-only?)
res)) (cut list <> entries))))
'())) '()))
(define (installed-package-entries profile ->entry) (define* (manifest-output-patterns manifest #:optional obsolete-only?)
"Return list of package entries for all installed packages." "Return a list of output patterns for MANIFEST entries.
(set-current-manifest-maybe! profile) If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only
(manifest-package-entries ->entry)) for obsolete packages."
(fold (lambda (entry res)
(manifest-patterns-result (manifest-entry->packages entry)
res
(lambda () entry)
(and (not obsolete-only?)
(cut list <> entry))))
'()
(manifest-entries manifest)))
(define (generation-package-entries profile ->entry generation) (define (obsolete-package-patterns manifest)
"Return list of package entries for packages from GENERATION." (manifest-package-patterns manifest #t))
(set-current-manifest-maybe!
(generation-file-name profile generation))
(manifest-package-entries ->entry))
(define (obsolete-package-entries profile _) (define (obsolete-output-patterns manifest)
"Return list of package entries for obsolete packages." (manifest-output-patterns manifest #t))
(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 ;;; Transforming package/output patterns into alists.
(define (profile-generations profile) (define (obsolete-package-sexp name version entries)
"Return list of generations for PROFILE." "Return an alist with information about obsolete package.
(let ((generations (generation-numbers profile))) ENTRIES is a list of installed manifest entries."
(if (equal? generations '(0)) `((id . ,(name+version->full-name name version))
'() (name . ,name)
generations))) (version . ,version)
(outputs . ,(map manifest-entry-output entries))
(obsolete . #t)
(installed . ,(manifest-entries->sexps entries))))
(define (package-pattern-transformer manifest params)
"Return 'package-pattern->package-sexps' procedure."
(define package->sexp
(object-transformer %package-param-alist params))
(define* (sexp-by-package package #:optional
(entries (manifest-entries-by-name
manifest
(package-name package)
(package-version package))))
(cons (cons 'installed (manifest-entries->sexps entries))
(package->sexp package)))
(define (->sexps pattern)
(match pattern
((? package? package)
(list (sexp-by-package package)))
(((? package? package) entries)
(list (sexp-by-package package entries)))
((name version entries)
(list (obsolete-package-sexp
name version entries)))
((name version)
(let ((packages (packages-by-name name version)))
(if (null? packages)
(let ((entries (manifest-entries-by-name
manifest name version)))
(if (null? entries)
'()
(list (obsolete-package-sexp
name version entries))))
(map sexp-by-package packages))))))
->sexps)
(define (output-pattern-transformer manifest params)
"Return 'output-pattern->output-sexps' procedure."
(define package->sexp
(object-transformer (alist-delete 'id %package-param-alist)
params))
(define manifest-entry->sexp
(object-transformer (alist-delete 'output %manifest-entry-param-alist)
params))
(define* (output-sexp pkg-alist pkg-address output
#:optional entry)
(let ((entry-alist (if entry
(manifest-entry->sexp entry)
'()))
(base `((id . ,(string-append
(number->string pkg-address)
":" output))
(output . ,output)
(installed . ,(->bool entry)))))
(append entry-alist base pkg-alist)))
(define (obsolete-output-sexp entry)
(let-values (((name version output)
(manifest-entry->name+version+output entry)))
(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 (manifest-entry->sexp entry) base))))
(define* (sexps-by-package package #:optional output
(entries (manifest-entries-by-name
manifest
(package-name package)
(package-version package))))
;; Assuming that PACKAGE has this OUTPUT.
(let ((pkg-alist (package->sexp package))
(address (object-address package))
(outputs (if output
(list output)
(package-outputs package))))
(map (lambda (output)
(output-sexp pkg-alist address output
(manifest-entry-by-output entries output)))
outputs)))
(define* (sexps-by-manifest-entry entry #:optional
(packages (manifest-entry->packages
entry)))
(if (null? packages)
(list (obsolete-output-sexp entry))
(map (lambda (package)
(output-sexp (package->sexp package)
(object-address package)
(manifest-entry-output entry)
entry))
packages)))
(define (->sexps pattern)
(match pattern
((? package? package)
(sexps-by-package package))
((package (? string? output))
(sexps-by-package package output))
((? manifest-entry? entry)
(list (obsolete-output-sexp entry)))
((package entry)
(sexps-by-manifest-entry entry (list package)))
((name version output)
(let ((packages (packages-by-name name version output)))
(if (null? packages)
(let ((entries (manifest-entries-by-name
manifest name version output)))
(append-map (cut sexps-by-manifest-entry <>)
entries))
(append-map (cut sexps-by-package <> output)
packages))))))
->sexps)
(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 procedures from inner alists are called with (MANIFEST . SEARCH-VALS)
;; as arguments; see `package/output-sexps'.
(define %patterns-makers
(let* ((apply-to-rest (lambda (proc)
(lambda (_ . rest) (apply proc rest))))
(apply-to-first (lambda (proc)
(lambda (first . _) (proc first))))
(manifest-package-proc (apply-to-first manifest-package-patterns))
(manifest-output-proc (apply-to-first manifest-output-patterns))
(regexp-proc (lambda (_ regexp params . __)
(packages-by-regexp regexp params)))
(all-proc (lambda _ (all-available-packages)))
(newest-proc (lambda _ (newest-available-packages))))
`((package
(id . ,(apply-to-rest ids->package-patterns))
(name . ,(apply-to-rest specifications->package-patterns))
(installed . ,manifest-package-proc)
(generation . ,manifest-package-proc)
(obsolete . ,(apply-to-first obsolete-package-patterns))
(regexp . ,regexp-proc)
(all-available . ,all-proc)
(newest-available . ,newest-proc))
(output
(id . ,(apply-to-rest ids->output-patterns))
(name . ,(apply-to-rest specifications->output-patterns))
(installed . ,manifest-output-proc)
(generation . ,manifest-output-proc)
(obsolete . ,(apply-to-first obsolete-output-patterns))
(regexp . ,regexp-proc)
(all-available . ,all-proc)
(newest-available . ,newest-proc)))))
(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 (package/output-sexps profile params entry-type
search-type search-vals)
"Return information about packages or package outputs.
See 'entry-sexps' for details."
(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))
(->sexps ((pattern-transformer entry-type) manifest params)))
(append-map ->sexps patterns)))
;;; Getting information about generations.
(define (generation-param-alist profile) (define (generation-param-alist profile)
"Return alist of generation parameters and functions for PROFILE." "Return an alist of generation parameters and procedures for PROFILE."
(list (list
(cons 'id identity) (cons 'id identity)
(cons 'number identity) (cons 'number identity)
@ -440,77 +644,86 @@ IDS may be an object-address, a full-name or a list of such elements."
(cons 'time (lambda (gen) (cons 'time (lambda (gen)
(time-second (generation-time profile gen)))))) (time-second (generation-time profile gen))))))
(define (matching-generation-entries profile ->entry predicate) (define (matching-generations profile predicate)
"Return list of generation entries for the matching generations. "Return a list of PROFILE generations matching PREDICATE."
PREDICATE is called on each generation." (filter predicate (profile-generations profile)))
(filter-map (lambda (gen)
(and (predicate gen) (->entry gen)))
(profile-generations profile)))
(define (last-generation-entries profile ->entry number) (define (last-generations profile number)
"Return list of last NUMBER generation entries. "Return a list of last NUMBER generations.
If NUMBER is 0 or less, return all generation entries." If NUMBER is 0 or less, return all generations."
(let ((generations (profile-generations profile)) (let ((generations (profile-generations profile))
(number (if (<= number 0) +inf.0 number))) (number (if (<= number 0) +inf.0 number)))
(map ->entry (if (> (length generations) number)
(if (> (length generations) number) (list-head (reverse generations) number)
(list-head (reverse generations) number) generations)))
generations))))
(define (all-generation-entries profile ->entry) (define (find-generations profile search-type search-vals)
"Return list of all generation entries." "Find PROFILE's generations matching SEARCH-TYPE and SEARCH-VALS."
(last-generation-entries profile ->entry +inf.0)) (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 (generation-entries-by-ids profile ->entry ids) (define (generation-sexps profile params search-type search-vals)
"Return list of generation entries for generations matching IDS. "Return information about generations.
IDS is a list of generation numbers." See 'entry-sexps' for details."
(matching-generation-entries profile ->entry (cut memq <> ids))) (let ((generations (find-generations profile search-type search-vals))
(->sexp (object-transformer (generation-param-alist profile)
params)))
(map ->sexp generations)))
;;; Getting package/generation entries ;;; Getting package/output/generation entries (alists).
(define %package-entries-functions (define (entries profile params entry-type search-type search-vals)
(alist->vhash "Return information about entries.
`((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 ENTRY-TYPE is a symbol defining a type of returning information. Should
(alist->vhash be: 'package', 'output' or 'generation'.
`((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) SEARCH-TYPE and SEARCH-VALS define how to get the information.
"Return list of entries. SEARCH-TYPE should be one of the following symbols:
ENTRY-TYPE and SEARCH-TYPE define a search function that should be
applied to PARAMS and VALS." - If ENTRY-TYPE is 'package' or 'output':
(let-values (((vhash ->entry) 'id', 'name', 'regexp', 'all-available', 'newest-available',
(case entry-type 'installed', 'obsolete', 'generation'.
((package)
(values %package-entries-functions - If ENTRY-TYPE is 'generation':
(object-transformer 'id', 'last', 'all'.
package-param-alist params)))
((generation) PARAMS is a list of parameters for receiving. If it is an empty list,
(values %generation-entries-functions get information with all available parameters, which are:
(object-transformer
(generation-param-alist profile) params))) - If ENTRY-TYPE is 'package':
(else (format (current-error-port) 'id', 'name', 'version', 'outputs', 'license', 'synopsis',
"Wrong entry type '~a'" entry-type))))) 'description', 'home-url', 'inputs', 'native-inputs',
(match (vhash-assq search-type vhash) 'propagated-inputs', 'location', 'installed'.
((key . fun)
(apply fun profile ->entry search-vals)) - If ENTRY-TYPE is 'output':
(_ '())))) 'id', 'package-id', 'name', 'version', 'output', 'license',
'synopsis', 'description', 'home-url', 'inputs', 'native-inputs',
'propagated-inputs', 'location', 'installed', 'path', 'dependencies'.
- If ENTRY-TYPE is 'generation':
'id', 'number', 'prev-number', 'path', 'time'.
Returning value is a list of alists. Each alist consists of
parameter/value pairs."
(case entry-type
((package output)
(package/output-sexps profile params entry-type
search-type search-vals))
((generation)
(generation-sexps profile params
search-type search-vals))
(else (entry-type-error entry-type))))
;;; Actions ;;; Package actions.
(define* (package->manifest-entry* package #:optional output) (define* (package->manifest-entry* package #:optional output)
(and package (and package
@ -600,4 +813,3 @@ OUTPUTS is a list of package outputs (may be an empty list)."
"~a packages in profile~%" "~a packages in profile~%"
count) count)
count))))))))) count)))))))))