guix/glob.scm

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