[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
121/182: ui: Produce hyperlinks for the 'location' field of search resul
From: |
guix-commits |
Subject: |
121/182: ui: Produce hyperlinks for the 'location' field of search results. |
Date: |
Fri, 15 Nov 2019 00:01:52 -0500 (EST) |
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))
- 91/182: gnu: libssh: Update to 0.9.2., (continued)
- 91/182: gnu: libssh: Update to 0.9.2., guix-commits, 2019/11/15
- 93/182: gnu: polybar: Update to 3.4.1., guix-commits, 2019/11/15
- 101/182: gnu: r-hmisc: Update to 4.3-0., guix-commits, 2019/11/15
- 109/182: guix: package: lock profiles when processing them., guix-commits, 2019/11/15
- 107/182: services: mpd: Connect to the user's PulseAudio socket., guix-commits, 2019/11/15
- 113/182: gnu: Add gnome-shell-extension-noannoyance., guix-commits, 2019/11/15
- 119/182: gnu: python-latexcodec: Update to 1.0.7., guix-commits, 2019/11/15
- 92/182: gnu: Fix deprecation of monolithic Qt 5.x package., guix-commits, 2019/11/15
- 108/182: guix: Add file-locking with no wait., guix-commits, 2019/11/15
- 112/182: gnu: Add gnome-shell-extension-dash-to-dock., guix-commits, 2019/11/15
- 121/182: ui: Produce hyperlinks for the 'location' field of search results.,
guix-commits <=
- 125/182: gnu: Add homebank., guix-commits, 2019/11/15
- 137/182: gnu: perl-file-configdir: Update to 0.021., guix-commits, 2019/11/15
- 120/182: gnu: botan: Update to 2.12.1., guix-commits, 2019/11/15
- 130/182: gnu: botan: Use getentropy()., guix-commits, 2019/11/15
- 123/182: news: Add Spanish translation., guix-commits, 2019/11/15
- 129/182: gnu: botan: Optimise., guix-commits, 2019/11/15
- 128/182: gnu: miniupnpc: Don't use NAME in source URI., guix-commits, 2019/11/15
- 133/182: gnu: fribidi: Fix CVE-2019-18397., guix-commits, 2019/11/15
- 136/182: gnu: perl-class-inspector: Update to 1.36., guix-commits, 2019/11/15
- 139/182: services: hpcguix-web: Delete lock files during activation., guix-commits, 2019/11/15