From 687c9bc0233facde4068ea7f9fed2b2ae931adab Mon Sep 17 00:00:00 2001
From: Alex Kost <alezost@gmail.com>
Date: Thu, 21 Jan 2016 22:07:10 +0300
Subject: emacs: Add interface for licenses.

* emacs/guix-main.scm (%license-param-alist): New variable.
  (license->sexp, find-licenses, license-entries): New procedures.
* emacs/guix-license.el (guix-license-get-entries)
  (guix-license-get-display, guix-license-insert-packages-button)
  (guix-license-insert-comment, guix-license-list-describe)
  (guix-license-list-show-packages): New procedures.
  (guix-licenses): New command.
* doc/emacs.texi (Emacs Licenses): New node.
  (Emacs Interface): Add it.
* doc/guix.texi (Top): Add it.
* NEWS: Mention new interface.
---
 emacs/guix-license.el | 86 +++++++++++++++++++++++++++++++++++++++++++++++++++
 emacs/guix-main.scm   | 22 +++++++++++++
 2 files changed, 108 insertions(+)

(limited to 'emacs')

diff --git a/emacs/guix-license.el b/emacs/guix-license.el
index 940f5518e2..a99d7af98d 100644
--- a/emacs/guix-license.el
+++ b/emacs/guix-license.el
@@ -23,22 +23,108 @@
 
 ;;; Code:
 
+(require 'guix-buffer)
+(require 'guix-list)
+(require 'guix-info)
 (require 'guix-read)
 (require 'guix-backend)
 (require 'guix-guile)
 
+(guix-define-entry-type license)
+
 (defun guix-lookup-license-url (license)
   "Return URL of a LICENSE."
   (or (guix-eval-read (guix-make-guile-expression
                        'lookup-license-uri license))
       (error "Hm, I don't know URL of '%s' license" license)))
 
+(defun guix-license-get-entries (search-type &rest args)
+  "Receive 'license' entries.
+SEARCH-TYPE may be one of the following symbols: `all', `id', `name'."
+  (guix-eval-read
+   (apply #'guix-make-guile-expression
+          'license-entries search-type args)))
+
+(defun guix-license-get-display (search-type &rest args)
+  "Search for licenses and show results."
+  (apply #'guix-list-get-display-entries
+         'license search-type args))
+
+
+;;; License 'info'
+
+(guix-info-define-interface license
+  :buffer-name "*Guix License Info*"
+  :get-entries-function 'guix-license-get-entries
+  :format '((name ignore (simple guix-info-heading))
+            ignore
+            guix-license-insert-packages-button
+            (url ignore (simple guix-url))
+            guix-license-insert-comment)
+  :titles '((url . "URL")))
+
+(declare-function guix-packages-by-license "guix-ui-package")
+
+(defun guix-license-insert-packages-button (entry)
+  "Insert button to display packages by license ENTRY."
+  (guix-info-insert-action-button
+   "Packages"
+   (lambda (btn)
+     (guix-packages-by-license (button-get btn 'license)))
+   "Show packages with this license"
+   'license (guix-entry-value entry 'name)))
+
+(defun guix-license-insert-comment (entry)
+  "Insert 'comment' of a license ENTRY."
+  (let ((comment (guix-entry-value entry 'comment)))
+    (if (and comment
+             (string-match-p "^http" comment))
+        (guix-info-insert-value-simple comment 'guix-url)
+      (guix-info-insert-title-simple
+       (guix-info-param-title 'license 'comment))
+      (guix-info-insert-value-indent comment))))
+
+
+;;; License 'list'
+
+(guix-list-define-interface license
+  :buffer-name "*Guix Licenses*"
+  :get-entries-function 'guix-license-get-entries
+  :describe-function 'guix-license-list-describe
+  :format '((name nil 40 t)
+            (url guix-list-get-url 50 t))
+  :titles '((name . "License"))
+  :sort-key '(name))
+
+(let ((map guix-license-list-mode-map))
+  (define-key map (kbd "RET") 'guix-license-list-show-packages))
+
+(defun guix-license-list-describe (ids)
+  "Describe licenses with IDS (list of identifiers)."
+  (guix-buffer-display-entries
+   (guix-entries-by-ids ids (guix-buffer-current-entries))
+   'info 'license (cl-list* 'id ids) 'add))
+
+(defun guix-license-list-show-packages ()
+  "Display packages with the license at point."
+  (interactive)
+  (guix-packages-by-license (guix-list-current-id)))
+
+
+;;; Interactive commands
+
 ;;;###autoload
 (defun guix-browse-license-url (license)
   "Browse URL of a LICENSE."
   (interactive (list (guix-read-license-name)))
   (browse-url (guix-lookup-license-url license)))
 
+;;;###autoload
+(defun guix-licenses ()
+  "Display licenses of the Guix packages."
+  (interactive)
+  (guix-license-get-display 'all))
+
 (provide 'guix-license)
 
 ;;; guix-license.el ends here
diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm
index bec26c7c40..335686ed25 100644
--- a/emacs/guix-main.scm
+++ b/emacs/guix-main.scm
@@ -1083,3 +1083,25 @@ Return #t if the shell command was executed successfully."
   "Return a license URI by its name."
   (and=> (lookup-license name)
          license-uri))
+
+(define %license-param-alist
+  `((id      . ,license-name)
+    (name    . ,license-name)
+    (url     . ,license-uri)
+    (comment . ,license-comment)))
+
+(define license->sexp
+  (object-transformer %license-param-alist))
+
+(define (find-licenses search-type . search-values)
+  "Return a list of licenses depending on SEARCH-TYPE and SEARCH-VALUES."
+  (case search-type
+    ((id name)
+     (let ((names search-values))
+       (filter-map lookup-license names)))
+    ((all)
+     (licenses))))
+
+(define (license-entries search-type . search-values)
+  (map license->sexp
+       (apply find-licenses search-type search-values)))
-- 
cgit 1.4.1