ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 15:36:20 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

emacs: Rewrite scheme side in a functional manner.

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

12
emacs/guix-base.el
View file

@ -323,8 +323,8 @@ following keywords are available:
Call an appropriate scheme function and return a list of the
form of `guix-entries'.
ENTRY-TYPE should be one of the following symbols: `package' or
`generation'.
ENTRY-TYPE should be one of the following symbols: `package',
`output' or `generation'.
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
information with all available parameters."
(guix-eval-read (guix-make-guile-expression
'get-entries
'entries
guix-current-profile params
entry-type search-type search-vals)))
@ -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))

3
emacs/guix-info.el
View file

@ -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 _)

872
emacs/guix-main.scm
View file

@ -20,17 +20,9 @@
;; 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 :)
;; ‘version’) and their values.
;; ‘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.
;; Since name/version pair is not necessarily unique, we use
@ -43,10 +35,6 @@
;; 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:
@ -55,10 +43,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:
@ -82,6 +66,9 @@ (define-syntax-rule (first-or-false lst)
(and (not (null? lst))
(first lst)))
(define (list-maybe obj)
(if (list? obj) obj (list obj)))
(define full-name->name+version package-name->name+version)
(define (name+version->full-name name version)
(string-append name "-" version))
@ -97,9 +84,6 @@ (define* (make-package-specification name #:optional version output)
(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,33 +103,165 @@ (define %package-table
%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)))))
(define (manifest-entry->name+version+output entry)
(values
(manifest-entry-name entry)
(manifest-entry-version entry)
(manifest-entry-output entry)))
(define (manifest-entries->hash-table entries)
"Return a hash table of name keys and lists of matching manifest ENTRIES."
(let ((table (make-hash-table (length entries))))
(for-each (lambda (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-table))
entries)))
(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-entry-by-output entries output)
"Return a manifest entry from ENTRIES matching OUTPUT."
(find (lambda (entry)
(string= output (manifest-entry-output entry)))
entries))
(define (manifest-entries-by-name+version name version)
(or (hash-ref %current-manifest-entries-table
(name+version->key name version))
'()))
(define (fold-manifest-by-name manifest proc init)
"Fold over MANIFEST entries.
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)
(or (hash-ref %package-table
@ -157,24 +273,12 @@ (define (packages-by-full-name full-name)
(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)
@ -183,166 +287,43 @@ (define (id->name+version id)
(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 (package-by-id id)
(first-or-false (packages-by-id id)))
(define (fold-object proc init obj)
(fold proc init
(if (list? obj) obj (list obj))))
(define (newest-package-by-id id)
(and=> (id->name+version id)
(lambda (name)
(first-or-false (find-best-packages-by-name name #f)))))
(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."
(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 (filter-packages-by-output packages output)
(filter (lambda (package)
(member output (package-outputs package)))
packages))
(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* (packages-by-name name #:optional version output)
"Return a 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 (manifest-entry->packages entry)
(call-with-values
(lambda () (manifest-entry->name+version+output entry))
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 a 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,88 +331,311 @@ (define (package-match? package regexp)
(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))))
(matching-packages (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 (all-available-packages)
"Return a list of all available packages."
(matching-packages (const #t)))
(define (newest-available-package-entries profile ->entry)
"Return list of package entries for the newest available packages."
(set-current-manifest-maybe! profile)
(define (newest-available-packages)
"Return a 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
(define (specification->package-pattern specification)
(call-with-values
(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)
;; 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))
(manifest-patterns-result (packages-by-name name version)
res
(lambda () (list name version entries))
(and (not obsolete-only?)
(cut list <> entries))))
'()))
(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* (manifest-output-patterns manifest #:optional obsolete-only?)
"Return a list of output patterns for MANIFEST entries.
If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only
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)
"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-patterns manifest)
(manifest-package-patterns manifest #t))
(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)))
'()))
(define (obsolete-output-patterns manifest)
(manifest-output-patterns manifest #t))
;;; Generation entries
;;; Transforming package/output patterns into alists.
(define (profile-generations profile)
"Return list of generations for PROFILE."
(let ((generations (generation-numbers profile)))
(if (equal? generations '(0))
'()
generations)))
(define (obsolete-package-sexp name version entries)
"Return an alist with information about obsolete package.
ENTRIES is a list of installed manifest entries."
`((id . ,(name+version->full-name name version))
(name . ,name)
(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)
"Return alist of generation parameters and functions for PROFILE."
"Return an alist of generation parameters and procedures for PROFILE."
(list
(cons 'id identity)
(cons 'number identity)
@ -440,77 +644,86 @@ (define (generation-param-alist 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 (matching-generations profile predicate)
"Return a 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 a 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))))
(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 (find-generations profile search-type search-vals)
"Find PROFILE's generations matching SEARCH-TYPE and 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 (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 (generation-sexps profile params search-type search-vals)
"Return information about generations.
See 'entry-sexps' for details."
(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
(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 (entries profile params entry-type search-type search-vals)
"Return information about entries.
(define %generation-entries-functions
(alist->vhash
`((id . ,generation-entries-by-ids)
(last . ,last-generation-entries)
(all . ,all-generation-entries))
hashq))
ENTRY-TYPE is a symbol defining a type of returning information. Should
be: 'package', 'output' or 'generation'.
(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))
(_ '()))))
SEARCH-TYPE and SEARCH-VALS define how to get the information.
SEARCH-TYPE should be one of the following symbols:
- If ENTRY-TYPE is 'package' or 'output':
'id', 'name', 'regexp', 'all-available', 'newest-available',
'installed', 'obsolete', 'generation'.
- If ENTRY-TYPE is 'generation':
'id', 'last', 'all'.
PARAMS is a list of parameters for receiving. If it is an empty list,
get information with all available parameters, which are:
- If ENTRY-TYPE is 'package':
'id', 'name', 'version', 'outputs', 'license', 'synopsis',
'description', 'home-url', 'inputs', 'native-inputs',
'propagated-inputs', 'location', 'installed'.
- 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)
(and package
@ -600,4 +813,3 @@ (define* (process-package-actions
"~a packages in profile~%"
count)
count)))))))))