08/08: glob: Add an extra glob pattern compilation stage.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 71e08fde28fa335bdba2ec2150fd6663390bba5a
Author: Ludovic Courtès <address@hidden>
Date:   Sun Mar 18 22:54:34 2018 +0100

    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'.
---
 gnu/build/linux-modules.scm |  4 ++--
 guix/glob.scm               | 51 +++++++++++++++++++++++++++++----------------
 tests/glob.scm              | 12 +++++------
 3 files changed, 41 insertions(+), 26 deletions(-)

diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index e97c9c9..87d2e98 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 29c335c..a9fc744 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 71e2d3f..3134069 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))