mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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'.
This commit is contained in:
parent
e914b398af
commit
71e08fde28
3 changed files with 41 additions and 26 deletions
|
@ -329,7 +329,7 @@ (define (read-module-aliases port)
|
|||
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 @@ (define (tokenize str)
|
|||
(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)))))))
|
||||
|
|
|
@ -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 @@ (define (parse-bracket chars)
|
|||
(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 @@ (define (cons-string chars lst)
|
|||
((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 @@ (define (glob-match? pattern str)
|
|||
(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)
|
||||
(((? char-set? cs) . 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)
|
||||
(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)
|
||||
|
|
|
@ -23,14 +23,14 @@ (define-module (test-glob)
|
|||
|
||||
(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 @@ (define-syntax test-glob-match
|
|||
((_ (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))
|
||||
|
|
Loading…
Reference in a new issue