121/182: ui: Produce hyperlinks for the 'location' field of search results.

[guix-commits]

kkebreau pushed a commit to branch wip-gnome-updates
in repository guix.

commit 5d2d8e69fbb08018dec267c90d4c19787da45512
Author: Ludovic Courtès <address@hidden>
Date:   Fri Nov 8 23:19:07 2019 +0100

    ui: Produce hyperlinks for the 'location' field of search results.
    
    This affects the output of 'guix show', 'guix search', and 'guix system
    search'.
    
    * guix/ui.scm (hyperlink, supports-hyperlinks?, location->hyperlink):
    New procedures.
    (package->recutils): Add #:hyperlinks? and honor it.
    (display-search-results): Pass #:hyperlinks? to PRINT.
    * guix/scripts/system/search.scm (service-type->recutils): Add
     #:hyperlinks? and honor it.
---
 guix/scripts/system/search.scm | 10 +++++---
 guix/ui.scm                    | 55 ++++++++++++++++++++++++++++++++++++------
 2 files changed, 54 insertions(+), 11 deletions(-)

diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm
index 5278062..d2eac06 100644
--- a/guix/scripts/system/search.scm
+++ b/guix/scripts/system/search.scm
@@ -65,9 +65,12 @@ provided TYPE has a default value."
 
 (define* (service-type->recutils type port
                                  #:optional (width (%text-width))
-                                 #:key (extra-fields '()))
+                                 #:key
+                                 (extra-fields '())
+                                 (hyperlinks? (supports-hyperlinks? port)))
   "Write to PORT a recutils record of TYPE, arranging to fit within WIDTH
-columns."
+columns.  When HYPERLINKS? is true, emit hyperlink escape sequences when
+appropriate."
   (define width*
     ;; The available number of columns once we've taken into account space for
     ;; the initial "+ " prefix.
@@ -84,7 +87,8 @@ columns."
   ;; Note: Don't i18n field names so that people can post-process it.
   (format port "name: ~a~%" (service-type-name type))
   (format port "location: ~a~%"
-          (or (and=> (service-type-location type) location->string)
+          (or (and=> (service-type-location type)
+                     (if hyperlinks? location->hyperlink location->string))
               (G_ "unknown")))
 
   (format port "extends: ~a~%"
diff --git a/guix/ui.scm b/guix/ui.scm
index 3e4bd57..bce0df5 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -69,6 +69,7 @@
   #:autoload   (system base compile) (compile-file)
   #:autoload   (system repl repl)  (start-repl)
   #:autoload   (system repl debug) (make-debug stack->vector)
+  #:autoload   (web uri) (encode-and-join-uri-path)
   #:use-module (texinfo)
   #:use-module (texinfo plain-text)
   #:use-module (texinfo string-utils)
@@ -108,6 +109,9 @@
             package->recutils
             package-specification->name+version+output
 
+            supports-hyperlinks?
+            location->hyperlink
+
             relevance
             package-relevance
             display-search-results
@@ -1234,10 +1238,42 @@ followed by \"+ \", which makes for a valid multi-line 
field value in the
                       '()
                       str)))
 
+(define (hyperlink uri text)
+  "Return a string that denotes a hyperlink using an OSC escape sequence as
+documented at
+<https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda>."
+  (string-append "\x1b]8;;" uri "\x1b\\"
+                 text "\x1b]8;;\x1b\\"))
+
+(define (supports-hyperlinks? port)
+  "Return true if PORT is a terminal that supports hyperlink escapes."
+  ;; Note that terminals are supposed to ignore OSC escapes they don't
+  ;; understand (this is the case of xterm as of version 349, for instance.)
+  ;; However, Emacs comint as of 26.3 does not ignore it and instead lets it
+  ;; through, hence the 'INSIDE_EMACS' special case below.
+  (and (isatty?* port)
+       (not (getenv "INSIDE_EMACS"))))
+
+(define (location->hyperlink location)
+  "Return a string corresponding to LOCATION, with escapes for a hyperlink."
+  (let ((str  (location->string location))
+        (file (if (string-prefix? "/" (location-file location))
+                  (location-file location)
+                  (search-path %load-path (location-file location)))))
+    (if file
+        (hyperlink (string-append "file://" (gethostname)
+                                  (encode-and-join-uri-path
+                                   (string-split file #\/)))
+                   str)
+        str)))
+
 (define* (package->recutils p port #:optional (width (%text-width))
-                            #:key (extra-fields '()))
+                            #:key
+                            (hyperlinks? (supports-hyperlinks? port))
+                            (extra-fields '()))
   "Write to PORT a `recutils' record of package P, arranging to fit within
-WIDTH columns.  EXTRA-FIELDS is a list of symbol/value pairs to emit."
+WIDTH columns.  EXTRA-FIELDS is a list of symbol/value pairs to emit.  When
+HYPERLINKS? is true, emit hyperlink escape sequences when appropriate."
   (define width*
     ;; The available number of columns once we've taken into account space for
     ;; the initial "+ " prefix.
@@ -1265,7 +1301,8 @@ WIDTH columns.  EXTRA-FIELDS is a list of symbol/value 
pairs to emit."
             (((labels inputs . _) ...)
              (dependencies->recutils (filter package? inputs)))))
   (format port "location: ~a~%"
-          (or (and=> (package-location p) location->string)
+          (or (and=> (package-location p)
+                     (if hyperlinks? location->hyperlink location->string))
               (G_ "unknown")))
 
   ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in
@@ -1398,11 +1435,13 @@ them.  If PORT is a terminal, print at most a full 
screen of results."
   (let loop ((matches matches))
     (match matches
       (((package . score) rest ...)
-       (let ((text (call-with-output-string
-                     (lambda (port)
-                       (print package port
-                              #:extra-fields
-                              `((relevance . ,score)))))))
+       (let* ((links? (supports-hyperlinks? port))
+              (text   (call-with-output-string
+                        (lambda (port)
+                          (print package port
+                                 #:hyperlinks? links?
+                                 #:extra-fields
+                                 `((relevance . ,score)))))))
          (if (and max-rows
                   (> (port-line port) first-line) ;print at least one result
                   (> (+ 4 (line-count text) (port-line port))