guix
/
guix
mirror of git://git.savannah.gnu.org/guix.git
3
4
Fork 0
Code Issues Releases Wiki Activity

describe: Use a procedure to format output. 

* guix/scripts/describe.scm (channel->sexp): New procedure.
(display-checkout-info, display-profile-info): Use this.
This commit is contained in:
Oleg Pykhalov 2018-11-21 16:45:08 +03:00
parent e3a2dd5559
commit 8548f99549
No known key found for this signature in database
GPG Key ID: 167F8EA5001AFA9C
1 changed files with 38 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
guix/scripts/describe.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -18,6 +19,7 @@
(define-module (guix scripts describe)
#:use-module ((guix ui) #:hide (display-profile-content))
#:use-module (guix channels)
#:use-module (guix scripts)
#:use-module (guix describe)
#:use-module (guix profiles)
@ -84,6 +86,12 @@ Display information about the channels currently in use.\n"))
(format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%")
string))))))
(define (channel->sexp channel)
`(channel
(name ,(channel-name channel))
(url ,(channel-url channel))
(commit ,(channel-commit channel))))
(define* (display-checkout-info fmt #:optional directory)
"Display information about the current checkout according to FMT, a symbol
denoting the requested format. Exit if the current directory does not lie
@ -104,10 +112,9 @@ within a Git checkout."
(format #t (G_ " branch: ~a~%") (reference-shorthand head))
(format #t (G_ " commit: ~a~%") commit))
('channels
(pretty-print `(list (channel
(name 'guix)
(url ,(dirname directory))
(commit ,commit))))))
(pretty-print `(list ,(channel->sexp (channel (name 'guix)
(url (dirname directory))
(commit commit)))))))
(display-package-search-path fmt)))
(define (display-profile-info profile fmt)
@ -116,34 +123,37 @@ in the format specified by FMT."
(define number
(generation-number profile))
(define channels
(map (lambda (entry)
(match (assq 'source (manifest-entry-properties entry))
(('source ('repository ('version 0)
('url url)
('branch branch)
('commit commit)
_ ...))
(channel (name (string->symbol (manifest-entry-name entry)))
(url url)
(commit commit)))
;; Pre-0.15.0 Guix does not provide that information,
;; so there's not much we can do in that case.
(_ (channel (name 'guix)
(url "?")
(commit "?")))))
;; Show most recently installed packages last.
(reverse
(manifest-entries
(profile-manifest
(if (zero? number)
profile
(generation-file-name profile number)))))))
(match fmt
('human
(display-profile-content profile number))
('channels
(pretty-print
`(list ,@(map (lambda (entry)
(match (assq 'source (manifest-entry-properties entry))
(('source ('repository ('version 0)
('url url)
('branch branch)
('commit commit)
_ ...))
`(channel (name ',(string->symbol
(manifest-entry-name entry)))
(url ,url)
(commit ,commit)))
;; Pre-0.15.0 Guix does not provide that information,
;; so there's not much we can do in that case.
(_ '???)))
;; Show most recently installed packages last.
(reverse
(manifest-entries
(profile-manifest
(if (zero? number)
profile
(generation-file-name profile number))))))))))
(pretty-print `(list ,@(map channel->sexp channels)))))
(display-package-search-path fmt))