* [bug#54823] [PATCH 2/3] colors: Add 'colorize-full-matches'.
2022-04-09 20:23 ` [bug#54823] [PATCH 1/3] ui: Highlight important bits in recutils output Ludovic Courtès
@ 2022-04-09 20:23 ` Ludovic Courtès
2022-04-09 20:23 ` [bug#54823] [PATCH 3/3] ui: Highlight package and service search results Ludovic Courtès
1 sibling, 0 replies; 5+ messages in thread
From: Ludovic Courtès @ 2022-04-09 20:23 UTC (permalink / raw)
To: 54823; +Cc: Ludovic Courtès
* guix/colors.scm (colorize-full-matches): New procedure.
---
guix/colors.scm | 22 ++++++++++++++++++++++
1 file changed, 22 insertions(+)
diff --git a/guix/colors.scm b/guix/colors.scm
index 3fd36c68ef..543f4c3ec5 100644
--- a/guix/colors.scm
+++ b/guix/colors.scm
@@ -36,6 +36,7 @@ (define-module (guix colors)
highlight/warn
dim
+ colorize-full-matches
color-rules
color-output?
isatty?*
@@ -153,6 +154,27 @@ (define highlight (coloring-procedure (color BOLD)))
(define highlight/warn (coloring-procedure (color BOLD MAGENTA)))
(define dim (coloring-procedure (color DARK)))
+(define (colorize-full-matches rules)
+ "Return a procedure that, given a string, colorizes according to RULES.
+RULES must be a list of regexp/color pairs; the whole match of a regexp is
+colorized with the corresponding color."
+ (define proc
+ (lambda (str)
+ (if (string-index str #\nul)
+ str
+ (let loop ((rules rules))
+ (match rules
+ (()
+ str)
+ (((regexp . color) . rest)
+ (match (regexp-exec regexp str)
+ (#f (loop rest))
+ (m (string-append (proc (match:prefix m))
+ (colorize-string (match:substring m)
+ color)
+ (proc (match:suffix m)))))))))))
+ proc)
+
(define (colorize-matches rules)
"Return a procedure that, when passed a string, returns that string
colorized according to RULES. RULES must be a list of tuples like:
--
2.35.1
^ permalink raw reply related [flat|nested] 5+ messages in thread* [bug#54823] [PATCH 3/3] ui: Highlight package and service search results.
2022-04-09 20:23 ` [bug#54823] [PATCH 1/3] ui: Highlight important bits in recutils output Ludovic Courtès
2022-04-09 20:23 ` [bug#54823] [PATCH 2/3] colors: Add 'colorize-full-matches' Ludovic Courtès
@ 2022-04-09 20:23 ` Ludovic Courtès
1 sibling, 0 replies; 5+ messages in thread
From: Ludovic Courtès @ 2022-04-09 20:23 UTC (permalink / raw)
To: 54823; +Cc: Ludovic Courtès
* guix/ui.scm (package->recutils): Add #:highlighting parameter and use it.
(display-search-results): Add #:regexps parameter; call
'colorize-full-matches' and pass #:highlighting.
* guix/scripts/package.scm (process-query): Pass #:regexps to
'display-search-results'.
* guix/scripts/home.scm (search): Likewise.
* guix/scripts/system/search.scm (service-type->recutils): Add #:highlighting
parameter and use it.
---
guix/scripts/home.scm | 1 +
guix/scripts/package.scm | 3 +-
guix/scripts/system/search.scm | 30 +++++++++++-------
guix/ui.scm | 57 ++++++++++++++++++++++------------
4 files changed, 60 insertions(+), 31 deletions(-)
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 341d83943d..f43bf865a7 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -733,6 +733,7 @@ (define (search . args)
(leave-on-EPIPE
(display-search-results matches (current-output-port)
#:print service-type->recutils
+ #:regexps regexps
#:command "guix home search")))))
\f
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 22ee8a2485..d007005607 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -885,7 +885,8 @@ (define (diff-profiles profile numbers)
(regexps (map (cut make-regexp* <> regexp/icase) patterns))
(matches (find-packages-by-description regexps)))
(leave-on-EPIPE
- (display-search-results matches (current-output-port)))
+ (display-search-results matches (current-output-port)
+ #:regexps regexps))
#t))
(('show _)
diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm
index 2a237e03d9..d70ed266f4 100644
--- a/guix/scripts/system/search.scm
+++ b/guix/scripts/system/search.scm
@@ -20,7 +20,7 @@
(define-module (guix scripts system search)
#:use-module (guix ui)
#:use-module (guix utils)
- #:autoload (guix colors) (highlight supports-hyperlinks?)
+ #:autoload (guix colors) (color-output? highlight supports-hyperlinks?)
#:autoload (guix diagnostics) (location->hyperlink)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
@@ -70,10 +70,12 @@ (define* (service-type->recutils type port
#:optional (width (%text-width))
#:key
(extra-fields '())
- (hyperlinks? (supports-hyperlinks? port)))
+ (hyperlinks? (supports-hyperlinks? port))
+ (highlighting identity))
"Write to PORT a recutils record of TYPE, arranging to fit within WIDTH
columns. When HYPERLINKS? is true, emit hyperlink escape sequences when
-appropriate."
+appropriate. Pass the description through HIGHLIGHTING, a one-argument
+procedure that may return a colorized version of its argument."
(define port*
(or (pager-wrapped-port port) port))
@@ -90,6 +92,11 @@ (define (extensions->recutils extensions)
(fill-paragraph list width*
(string-length "extends: ")))))
+ (define highlighting*
+ (if (color-output? port*)
+ highlighting
+ identity))
+
;; Note: Don't i18n field names so that people can post-process it.
(format port "name: ~a~%"
(highlight (symbol->string (service-type-name type))
@@ -114,14 +121,15 @@ (define (extensions->recutils extensions)
(when (service-type-description type)
(format port "~a~%"
- (string->recutils
- (string-trim-right
- (parameterize ((%text-width width*))
- (texi->plain-text
- (string-append "description: "
- (or (and=> (service-type-description type) P_)
- ""))))
- #\newline))))
+ (highlighting*
+ (string->recutils
+ (string-trim-right
+ (parameterize ((%text-width width*))
+ (texi->plain-text
+ (string-append "description: "
+ (or (and=> (service-type-description type) P_)
+ ""))))
+ #\newline)))))
(for-each (match-lambda
((field . value)
diff --git a/guix/ui.scm b/guix/ui.scm
index 555a614faa..cb68a07c6c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1485,10 +1485,13 @@ (define (string->recutils str)
(define* (package->recutils p port #:optional (width (%text-width))
#:key
(hyperlinks? (supports-hyperlinks? port))
- (extra-fields '()))
+ (extra-fields '())
+ (highlighting identity))
"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. When
-HYPERLINKS? is true, emit hyperlink escape sequences when appropriate."
+HYPERLINKS? is true, emit hyperlink escape sequences when appropriate. Pass
+the synopsis and description through HIGHLIGHTING, a one-argument procedure
+that may return a colorized version of its argument."
(define port*
(or (pager-wrapped-port port) port))
@@ -1510,6 +1513,11 @@ (define (dependencies->recutils packages)
(define (package<? p1 p2)
(string<? (package-full-name p1) (package-full-name p2)))
+ (define highlighting*
+ (if (color-output? port*)
+ highlighting
+ identity))
+
;; Note: Don't i18n field names so that people can post-process it.
(format port "name: ~a~%" (highlight (package-name p) port*))
(format port "version: ~a~%" (highlight (package-version p) port*))
@@ -1544,22 +1552,24 @@ (define (package<? p1 p2)
(x
(G_ "unknown"))))
(format port "synopsis: ~a~%"
- (string-map (match-lambda
- (#\newline #\space)
- (chr chr))
- (or (package-synopsis-string p) "")))
+ (highlighting*
+ (string-map (match-lambda
+ (#\newline #\space)
+ (chr chr))
+ (or (package-synopsis-string p) ""))))
(format port "~a~%"
- (string->recutils
- (string-trim-right
- (parameterize ((%text-width width*))
- ;; Call 'texi->plain-text' on the concatenated string to account
- ;; for the width of "description:" in paragraph filling.
- (texi->plain-text*
- p
- (string-append "description: "
- (or (and=> (package-description p) P_)
- ""))))
- #\newline)))
+ (highlighting*
+ (string->recutils
+ (string-trim-right
+ (parameterize ((%text-width width*))
+ ;; Call 'texi->plain-text' on the concatenated string to account
+ ;; for the width of "description:" in paragraph filling.
+ (texi->plain-text*
+ p
+ (string-append "description: "
+ (or (and=> (package-description p) P_)
+ ""))))
+ #\newline))))
(for-each (match-lambda
((field . value)
(let ((field (symbol->string field)))
@@ -1707,10 +1717,12 @@ (define-syntax with-paginated-output-port
(define* (display-search-results matches port
#:key
+ (regexps '())
(command "guix search")
(print package->recutils))
"Display MATCHES, a list of object/score pairs, by calling PRINT on each of
-them. If PORT is a terminal, print at most a full screen of results."
+them. If PORT is a terminal, print at most a full screen of results. REGEXPS
+is a list of regexps to highlight in search results."
(define first-line
(port-line port))
@@ -1721,6 +1733,12 @@ (define max-rows
(define (line-count str)
(string-count str #\newline))
+ (define highlighting
+ (let ((match-color (color ON-RED BOLD)))
+ (colorize-full-matches (map (lambda (regexp)
+ (cons regexp match-color))
+ regexps))))
+
(with-paginated-output-port paginated
(let loop ((matches matches))
(match matches
@@ -1728,7 +1746,8 @@ (define (line-count str)
(let* ((links? (supports-hyperlinks? port)))
(print package paginated
#:hyperlinks? links?
- #:extra-fields `((relevance . ,score)))
+ #:extra-fields `((relevance . ,score))
+ #:highlighting highlighting)
(loop rest)))
(()
#t)))))
--
2.35.1
^ permalink raw reply related [flat|nested] 5+ messages in thread