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 and square brackets, for instance.
  29 ;;;
  30 ;;; Code:
  31
  32 (define (wildcard-indices str)
  33   "Return the list of indices in STR where wildcards can be found."
  34   (let loop ((index 0)
  35              (result '()))
  36     (if (= index (string-length str))
  37         (reverse result)
  38         (loop (+ 1 index)
  39               (case (string-ref str index)
  40                 ((#\? #\*) (cons index result))
  41                 (else      result))))))
  42
  43 (define (compile-glob-pattern str)
  44   "Return an sexp that represents the compiled form of STR, a glob pattern
  45 such as \"foo*\" or \"foo??bar\"."
  46   (define flatten
  47     (match-lambda
  48       (((? string? str)) str)
  49       (x x)))
  50
  51   (let loop ((index   0)
  52              (indices (wildcard-indices str))
  53              (result '()))
  54     (match indices
  55       (()
  56        (flatten (cond ((zero? index)
  57                        (list str))
  58                       ((= index (string-length str))
  59                        (reverse result))
  60                       (else
  61                        (reverse (cons (string-drop str index)
  62                                       result))))))
  63       ((wildcard-index . rest)
  64        (let ((wildcard (match (string-ref str wildcard-index)
  65                          (#\? '?)
  66                          (#\* '*))))
  67          (match (substring str index wildcard-index)
  68            (""  (loop (+ 1 wildcard-index)
  69                       rest
  70                       (cons wildcard result)))
  71            (str (loop (+ 1 wildcard-index)
  72                       rest
  73                       (cons* wildcard str result)))))))))
  74
  75 (define (glob-match? pattern str)
  76   "Return true if STR matches PATTERN, a compiled glob pattern as returned by
  77 'compile-glob-pattern'."
  78   (let loop ((pattern pattern)
  79              (str str))
  80    (match pattern
  81      ((? string? literal) (string=? literal str))
  82      (((? string? one))   (string=? one str))
  83      (('*)  #t)
  84      (('?) (= 1 (string-length str)))
  85      (()    #t)
  86      (('* suffix . rest)
  87       (match (string-contains str suffix)
  88         (#f    #f)
  89         (index (loop rest
  90                      (string-drop str
  91                                   (+ index (string-length suffix)))))))
  92      (('? . rest)
  93       (and (>= (string-length str) 1)
  94            (loop rest (string-drop str 1))))
  95      ((prefix . rest)
  96       (and (string-prefix? prefix str)
  97            (loop rest (string-drop str (string-length prefix))))))))