[bug#33448] [PATCH] describe: Add json format.

[Oleg Pykhalov <go.wigust@gmail.com>]

* guix/scripts/describe.scm: Add json format.
---
 guix/scripts/describe.scm | 69 +++++++++++++++++++++++++--------------
 1 file changed, 44 insertions(+), 25 deletions(-)

diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index d3203e992..53195b423 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -23,6 +23,7 @@
   #:use-module (guix profiles)
   #:use-module ((guix scripts pull) #:select (display-profile-content))
   #:use-module (git)
+  #:use-module (json)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
@@ -38,7 +39,7 @@
   ;; Specifications of the command-line options.
   (list (option '(#\f "format") #t #f
                 (lambda (opt name arg result)
-                  (unless (member arg '("human" "channels"))
+                  (unless (member arg '("human" "channels" "json"))
                     (leave (G_ "~a: unsupported output format~%") arg))
                   (alist-cons 'format (string->symbol arg) result)))
         (option '(#\h "help") #f #f
@@ -101,7 +102,12 @@ within a Git checkout."
        (pretty-print `(list (channel
                              (name 'guix)
                              (url ,(dirname directory))
-                             (commit ,commit))))))
+                             (commit ,commit)))))
+      ('json
+       (display (scm->json-string `((name . guix)
+                                    (url . ,(dirname directory))
+                                    (commit . ,commit))))
+       (newline)))
     (display-package-search-path fmt)))
 
 (define (display-profile-info profile fmt)
@@ -110,34 +116,47 @@ in the format specified by FMT."
   (define number
     (generation-number profile))
 
+  (define (channels format)
+    (map (lambda (entry)
+           (match (assq 'source (manifest-entry-properties entry))
+             (('source ('repository ('version 0)
+                                    ('url url)
+                                    ('branch branch)
+                                    ('commit commit)
+                                    _ ...))
+              (case format
+                ((scm)
+                 `(channel (name ',(string->symbol
+                                    (manifest-entry-name entry)))
+                           (url ,url)
+                           (commit ,commit)))
+                ((json)
+                 `((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)))))))
+
   (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))))))))))
+      `(list ,@(channels 'scm))))
+    ('json
+     (display (scm->json-string (channels 'json)))
+     (newline)))
   (display-package-search-path fmt))
 
 \f
-- 
2.19.1