Browse Source

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'.
gn-latest-20200428
Ludovic Courtès 4 years ago
parent
commit
71e08fde28
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
  1. 4
      gnu/build/linux-modules.scm
  2. 51
      guix/glob.scm
  3. 12
      tests/glob.scm

4
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)))))))

51
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)

12
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))

Loading…
Cancel
Save