aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-03-18 22:54:34 +0100
committerLudovic Courtès <ludo@gnu.org>2018-03-18 22:57:17 +0100
commit71e08fde28fa335bdba2ec2150fd6663390bba5a (patch)
tree71d35060faa1f92b6e15236098a58c4da6e8d84f
parente914b398af11f909e88a8bc85eeebb0768aacd54 (diff)
downloadguix-71e08fde28fa335bdba2ec2150fd6663390bba5a.tar
guix-71e08fde28fa335bdba2ec2150fd6663390bba5a.tar.gz
glob: Add an extra glob pattern compilation stage.
* guix/glob.scm (compile-glob-pattern): Rename to... (string->sglob): ... this. (compile-sglob, string->compiled-sglob): New procedures. (glob-match?): Replace '?, 'range, and 'set with a single clause. * tests/glob.scm (test-compile-glob-pattern): Rename to... (test-string->sglob): ... this. Adjust accordingly. (test-glob-match): Use 'string->compiled-sglob' instead of 'compile-glob-pattern'. * gnu/build/linux-modules.scm (read-module-aliases): Use 'string->compiled-sglob' instead of 'compile-glob-pattern'.
-rw-r--r--gnu/build/linux-modules.scm4
-rw-r--r--guix/glob.scm51
-rw-r--r--tests/glob.scm12
3 files changed, 41 insertions, 26 deletions
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index e97c9c95f1..87d2e98edf 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -329,7 +329,7 @@ The modules corresponding to these aliases can then be found using
list of alias/module pairs where each alias is a glob pattern as like the
result of:
- (compile-glob-pattern \"scsi:t-0x01*\")
+ (string->compiled-sglob \"scsi:t-0x01*\")
and each module is a module name like \"snd_hda_intel\"."
(define (comment? str)
@@ -354,7 +354,7 @@ and each module is a module name like \"snd_hda_intel\"."
(line
(match (tokenize line)
(("alias" alias module)
- (loop (alist-cons (compile-glob-pattern alias) module
+ (loop (alist-cons (string->compiled-sglob alias) module
aliases)))
(() ;empty line
(loop aliases)))))))
diff --git a/guix/glob.scm b/guix/glob.scm
index 29c335ca1d..a9fc744802 100644
--- a/guix/glob.scm
+++ b/guix/glob.scm
@@ -18,7 +18,9 @@
(define-module (guix glob)
#:use-module (ice-9 match)
- #:export (compile-glob-pattern
+ #:export (string->sglob
+ compile-sglob
+ string->compiled-sglob
glob-match?))
;;; Commentary:
@@ -37,9 +39,9 @@
(lst
`(set ,@lst))))
-(define (compile-glob-pattern str)
- "Return an sexp that represents the compiled form of STR, a glob pattern
-such as \"foo*\" or \"foo??bar\"."
+(define (string->sglob str)
+ "Return an sexp, called an \"sglob\", that represents the compiled form of
+STR, a glob pattern such as \"foo*\" or \"foo??bar\"."
(define flatten
(match-lambda
(((? string? str)) str)
@@ -83,9 +85,33 @@ such as \"foo*\" or \"foo??bar\"."
((chr . rest)
(loop rest (cons chr pending) brackets result)))))
+(define (compile-sglob sglob)
+ "Compile SGLOB into a more efficient representation."
+ (if (string? sglob)
+ sglob
+ (let loop ((sglob sglob)
+ (result '()))
+ (match sglob
+ (()
+ (reverse result))
+ (('? . rest)
+ (loop rest (cons char-set:full result)))
+ ((('range start end) . rest)
+ (loop rest (cons (ucs-range->char-set
+ (char->integer start)
+ (+ 1 (char->integer end)))
+ result)))
+ ((('set . chars) . rest)
+ (loop rest (cons (list->char-set chars) result)))
+ ((head . rest)
+ (loop rest (cons head result)))))))
+
+(define string->compiled-sglob
+ (compose compile-sglob string->sglob))
+
(define (glob-match? pattern str)
"Return true if STR matches PATTERN, a compiled glob pattern as returned by
-'compile-glob-pattern'."
+'compile-sglob'."
(let loop ((pattern pattern)
(str str))
(match pattern
@@ -101,21 +127,10 @@ such as \"foo*\" or \"foo??bar\"."
(index (loop rest
(string-drop str
(+ index (string-length suffix)))))))
- (('? . rest)
- (and (>= (string-length str) 1)
- (loop rest (string-drop str 1))))
- ((('range start end) . rest)
- (and (>= (string-length str) 1)
- (let ((chr (string-ref str 0)))
- (and (char-set-contains? (ucs-range->char-set
- (char->integer start)
- (+ 1 (char->integer end)))
- chr)
- (loop rest (string-drop str 1))))))
- ((('set . chars) . rest)
+ (((? char-set? cs) . rest)
(and (>= (string-length str) 1)
(let ((chr (string-ref str 0)))
- (and (char-set-contains? (list->char-set chars) chr)
+ (and (char-set-contains? cs chr)
(loop rest (string-drop str 1))))))
((prefix . rest)
(and (string-prefix? prefix str)
diff --git a/tests/glob.scm b/tests/glob.scm
index 71e2d3fce0..3134069789 100644
--- a/tests/glob.scm
+++ b/tests/glob.scm
@@ -23,14 +23,14 @@
(test-begin "glob")
-(define-syntax test-compile-glob-pattern
+(define-syntax test-string->sglob
(syntax-rules (=>)
((_ pattern => result rest ...)
(begin
- (test-equal (format #f "compile-glob-pattern, ~s" pattern)
+ (test-equal (format #f "string->sglob, ~s" pattern)
result
- (compile-glob-pattern pattern))
- (test-compile-glob-pattern rest ...)))
+ (string->sglob pattern))
+ (test-string->sglob rest ...)))
((_)
#t)))
@@ -39,14 +39,14 @@
((_ (pattern-string matches strings ... (and not others ...)) rest ...)
(begin
(test-assert (format #f "glob-match? ~s" pattern-string)
- (let ((pattern (compile-glob-pattern pattern-string)))
+ (let ((pattern (string->compiled-sglob pattern-string)))
(and (glob-match? pattern strings) ...
(not (glob-match? pattern others)) ...)))
(test-glob-match rest ...)))
((_)
#t)))
-(test-compile-glob-pattern
+(test-string->sglob
"foo" => "foo"
"?foo*" => '(? "foo" *)
"foo[1-5]" => '("foo" (range #\1 #\5))