kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

gnu-maintenance: Use `recutils->alist'.

Browse Source 
* guix/gnu-maintenance.scm (official-gnu-packages)[group-package-fields]:
  Rewrite in terms of `recutils->alist'.  Remove `state' parameter.
  Specify "doc-url" and "language" as multiple-value keys in the
  `alist->record' call.
This commit is contained in:
Ludovic Courtès 2013-07-10 18:08:09 +02:00
parent c8772a7a21
commit b0efe83a8f
1 changed files with 13 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
guix/gnu-maintenance.scm
View File

@ -22,7 +22,6 @@
#:use-module (web client) #:use-module (web client)
#:use-module (web response) #:use-module (web response)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
@ -92,64 +91,24 @@
(copyright-holder gnu-package-copyright-holder) (copyright-holder gnu-package-copyright-holder)
(savannah gnu-package-savannah) (savannah gnu-package-savannah)
(fsd gnu-package-fsd) (fsd gnu-package-fsd)
(language gnu-package-language) (language gnu-package-language) ; list of strings
(logo gnu-package-logo) (logo gnu-package-logo)
(doc-category gnu-package-doc-category) (doc-category gnu-package-doc-category)
(doc-summary gnu-package-doc-summary) (doc-summary gnu-package-doc-summary)
(doc-urls gnu-package-doc-urls) (doc-urls gnu-package-doc-urls) ; list of strings
(download-url gnu-package-download-url)) (download-url gnu-package-download-url))
(define (official-gnu-packages) (define (official-gnu-packages)
"Return a list of records, which are GNU packages." "Return a list of records, which are GNU packages."
(define (group-package-fields port state) (define (group-package-fields port)
;; Return a list of alists. Each alist contains fields of a GNU ;; Return a list of alists. Each alist contains fields of a GNU
;; package. ;; package.
(let ((line (read-line port)) (let loop ((alist (recutils->alist port))
(field-rx (make-regexp "^([[:graph:]]+): (.*)$")) (result '()))
(doc-urls-rx (make-regexp "^doc-url: (.*)$")) (if (null? alist)
(end-rx (make-regexp "^# End. .+Do not remove this line.+"))) result
(loop (recutils->alist port)
(define (match-field str) (cons alist result)))))
;; Packages are separated by empty strings. If STR is an
;; empty string, create a new list to store fields of a
;; different package. Otherwise, match and create a key-value
;; pair.
(match str
(""
(group-package-fields port (cons '() state)))
(str
(cond ((regexp-exec doc-urls-rx str)
=>
(lambda (match)
(if (equal? (assoc-ref (first state) "doc-urls") #f)
(group-package-fields
port (cons (cons (cons "doc-urls"
(list
(match:substring match 1)))
(first state))
(drop state 1)))
(group-package-fields
port (cons (cons (cons "doc-urls"
(cons (match:substring match 1)
(assoc-ref (first state)
"doc-urls")))
(assoc-remove! (first state)
"doc-urls"))
(drop state 1))))))
((regexp-exec field-rx str)
=>
(lambda (match)
(group-package-fields
port (cons (cons (cons (match:substring match 1)
(match:substring match 2))
(first state))
(drop state 1)))))
(else (group-package-fields port state))))))
(if (or (eof-object? line)
(regexp-exec end-rx line)) ; don't include dummy fields
(remove null-list? state)
(match-field line))))
(reverse (reverse
(map (lambda (alist) (map (lambda (alist)
@ -157,10 +116,10 @@
make-gnu-package-descriptor make-gnu-package-descriptor
(list "package" "mundane-name" "copyright-holder" (list "package" "mundane-name" "copyright-holder"
"savannah" "fsd" "language" "logo" "savannah" "fsd" "language" "logo"
"doc-category" "doc-summary" "doc-urls" "doc-category" "doc-summary" "doc-url"
"download-url"))) "download-url")
(group-package-fields (http-fetch %package-list-url #:text? #t) '("doc-url" "language")))
'(()))))) (group-package-fields (http-fetch %package-list-url #:text? #t)))))
(define (find-packages regexp) (define (find-packages regexp)
"Find GNU packages which satisfy REGEXP." "Find GNU packages which satisfy REGEXP."