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 (string->sglob
  22             compile-sglob
  23             string->compiled-sglob
  24             glob-match?))
  25
  26 ;;; Commentary:
  27 ;;;
  28 ;;; This is a minimal implementation of "glob patterns" (info "(libc)
  29 ;;; Globbbing").  It is currently limited to simple patterns and does not
  30 ;;; support braces, for instance.
  31 ;;;
  32 ;;; Code:
  33
  34 (define (parse-bracket chars)
  35   "Parse CHARS, a list of characters that extracted from a '[...]' sequence."
  36   (match chars
  37     ((start #\- end)
  38      `(range ,start ,end))
  39     (lst
  40      `(set ,@lst))))
  41
  42 (define (string->sglob str)
  43   "Return an sexp, called an \"sglob\", that represents the compiled form of
  44 STR, a glob pattern such as \"foo*\" or \"foo??bar\"."
  45   (define flatten
  46     (match-lambda
  47       (((? string? str)) str)
  48       (x x)))
  49
  50   (define (cons-string chars lst)
  51     (match chars
  52       (() lst)
  53       (_ (cons (list->string (reverse chars)) lst))))
  54
  55   (let loop ((chars   (string->list str))
  56              (pending '())
  57              (brackets 0)
  58              (result '()))
  59     (match chars
  60       (()
  61        (flatten (reverse (if (null? pending)
  62                              result
  63                              (cons-string pending result)))))
  64       (((and chr (or #\? #\*)) . rest)
  65        (let ((wildcard (match chr
  66                          (#\? '?)
  67                          (#\* '*))))
  68          (if (zero? brackets)
  69              (loop rest '() 0
  70                    (cons* wildcard (cons-string pending result)))
  71              (loop rest (cons chr pending) brackets result))))
  72       ((#\[ . rest)
  73        (if (zero? brackets)
  74            (loop rest '() (+ 1 brackets)
  75                  (cons-string pending result))
  76            (loop rest (cons #\[ pending) (+ 1 brackets) result)))
  77       ((#\] . rest)
  78        (cond ((zero? brackets)
  79               (error "unexpected closing bracket" str))
  80              ((= 1 brackets)
  81               (loop rest '() 0
  82                     (cons (parse-bracket (reverse pending)) result)))
  83              (else
  84               (loop rest (cons #\] pending) (- brackets 1) result))))
  85       ((chr . rest)
  86        (loop rest (cons chr pending) brackets result)))))
  87
  88 (define (compile-sglob sglob)
  89   "Compile SGLOB into a more efficient representation."
  90   (if (string? sglob)
  91       sglob
  92       (let loop ((sglob sglob)
  93                  (result '()))
  94         (match sglob
  95           (()
  96            (reverse result))
  97           (('? . rest)
  98            (loop rest (cons char-set:full result)))
  99           ((('range start end) . rest)
 100            (loop rest (cons (ucs-range->char-set
 101                              (char->integer start)
 102                              (+ 1 (char->integer end)))
 103                             result)))
 104           ((('set . chars) . rest)
 105            (loop rest (cons (list->char-set chars) result)))
 106           ((head . rest)
 107            (loop rest (cons head result)))))))
 108
 109 (define string->compiled-sglob
 110   (compose compile-sglob string->sglob))
 111
 112 (define (glob-match? pattern str)
 113   "Return true if STR matches PATTERN, a compiled glob pattern as returned by
 114 'compile-sglob'."
 115   (let loop ((pattern pattern)
 116              (str str))
 117    (match pattern
 118      ((? string? literal)
 119       (string=? literal str))
 120      (()
 121       (string-null? str))
 122      (('*)
 123       #t)
 124      (('* suffix . rest)
 125       (match (string-contains str suffix)
 126         (#f    #f)
 127         (index (loop rest
 128                      (string-drop str
 129                                   (+ index (string-length suffix)))))))
 130      (((? char-set? cs) . rest)
 131       (and (>= (string-length str) 1)
 132            (let ((chr (string-ref str 0)))
 133              (and (char-set-contains? cs chr)
 134                   (loop rest (string-drop str 1))))))
 135      ((prefix . rest)
 136       (and (string-prefix? prefix str)
 137            (loop rest (string-drop str (string-length prefix))))))))