guix/glob.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix glob)
  20   #:use-module (ice-9 match)
  21   #:export (compile-glob-pattern
  22             glob-match?))
  23
  24 ;;; Commentary:
  25 ;;;
  26 ;;; This is a minimal implementation of "glob patterns" (info "(libc)
  27 ;;; Globbbing").  It is currently limited to simple patterns and does not
  28 ;;; support braces, for instance.
  29 ;;;
  30 ;;; Code:
  31
  32 (define (parse-bracket chars)
  33   "Parse CHARS, a list of characters that extracted from a '[...]' sequence."
  34   (match chars
  35     ((start #\- end)
  36      `(range ,start ,end))
  37     (lst
  38      `(set ,@lst))))
  39
  40 (define (compile-glob-pattern str)
  41   "Return an sexp that represents the compiled form of STR, a glob pattern
  42 such as \"foo*\" or \"foo??bar\"."
  43   (define flatten
  44     (match-lambda
  45       (((? string? str)) str)
  46       (x x)))
  47
  48   (define (cons-string chars lst)
  49     (match chars
  50       (() lst)
  51       (_ (cons (list->string (reverse chars)) lst))))
  52
  53   (let loop ((chars   (string->list str))
  54              (pending '())
  55              (brackets 0)
  56              (result '()))
  57     (match chars
  58       (()
  59        (flatten (reverse (if (null? pending)
  60                              result
  61                              (cons-string pending result)))))
  62       (((and chr (or #\? #\*)) . rest)
  63        (let ((wildcard (match chr
  64                          (#\? '?)
  65                          (#\* '*))))
  66          (if (zero? brackets)
  67              (loop rest '() 0
  68                    (cons* wildcard (cons-string pending result)))
  69              (loop rest (cons chr pending) brackets result))))
  70       ((#\[ . rest)
  71        (if (zero? brackets)
  72            (loop rest '() (+ 1 brackets)
  73                  (cons-string pending result))
  74            (loop rest (cons #\[ pending) (+ 1 brackets) result)))
  75       ((#\] . rest)
  76        (cond ((zero? brackets)
  77               (error "unexpected closing bracket" str))
  78              ((= 1 brackets)
  79               (loop rest '() 0
  80                     (cons (parse-bracket (reverse pending)) result)))
  81              (else
  82               (loop rest (cons #\] pending) (- brackets 1) result))))
  83       ((chr . rest)
  84        (loop rest (cons chr pending) brackets result)))))
  85
  86 (define (glob-match? pattern str)
  87   "Return true if STR matches PATTERN, a compiled glob pattern as returned by
  88 'compile-glob-pattern'."
  89   (let loop ((pattern pattern)
  90              (str str))
  91    (match pattern
  92      ((? string? literal)
  93       (string=? literal str))
  94      (()
  95       (string-null? str))
  96      (('*)
  97       #t)
  98      (('* suffix . rest)
  99       (match (string-contains str suffix)
 100         (#f    #f)
 101         (index (loop rest
 102                      (string-drop str
 103                                   (+ index (string-length suffix)))))))
 104      (('? . rest)
 105       (and (>= (string-length str) 1)
 106            (loop rest (string-drop str 1))))
 107      ((('range start end) . rest)
 108       (and (>= (string-length str) 1)
 109            (let ((chr (string-ref str 0)))
 110              (and (char-set-contains? (ucs-range->char-set
 111                                        (char->integer start)
 112                                        (+ 1 (char->integer end)))
 113                                       chr)
 114                   (loop rest (string-drop str 1))))))
 115      ((('set . chars) . rest)
 116       (and (>= (string-length str) 1)
 117            (let ((chr (string-ref str 0)))
 118              (and (char-set-contains? (list->char-set chars) chr)
 119                   (loop rest (string-drop str 1))))))
 120      ((prefix . rest)
 121       (and (string-prefix? prefix str)
 122            (loop rest (string-drop str (string-length prefix))))))))