138 lines
4.5 KiB
Scheme
138 lines
4.5 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
|
|
;;;
|
|
;;; This file is part of GNU Guix.
|
|
;;;
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (guix glob)
|
|
#:use-module (ice-9 match)
|
|
#:export (string->sglob
|
|
compile-sglob
|
|
string->compiled-sglob
|
|
glob-match?))
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; This is a minimal implementation of "glob patterns" (info "(libc)
|
|
;;; Globbbing"). It is currently limited to simple patterns and does not
|
|
;;; support braces, for instance.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define (parse-bracket chars)
|
|
"Parse CHARS, a list of characters that extracted from a '[...]' sequence."
|
|
(match chars
|
|
((start #\- end)
|
|
`(range ,start ,end))
|
|
(lst
|
|
`(set ,@lst))))
|
|
|
|
(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)
|
|
(x x)))
|
|
|
|
(define (cons-string chars lst)
|
|
(match chars
|
|
(() lst)
|
|
(_ (cons (list->string (reverse chars)) lst))))
|
|
|
|
(let loop ((chars (string->list str))
|
|
(pending '())
|
|
(brackets 0)
|
|
(result '()))
|
|
(match chars
|
|
(()
|
|
(flatten (reverse (if (null? pending)
|
|
result
|
|
(cons-string pending result)))))
|
|
(((and chr (or #\? #\*)) . rest)
|
|
(let ((wildcard (match chr
|
|
(#\? '?)
|
|
(#\* '*))))
|
|
(if (zero? brackets)
|
|
(loop rest '() 0
|
|
(cons* wildcard (cons-string pending result)))
|
|
(loop rest (cons chr pending) brackets result))))
|
|
((#\[ . rest)
|
|
(if (zero? brackets)
|
|
(loop rest '() (+ 1 brackets)
|
|
(cons-string pending result))
|
|
(loop rest (cons #\[ pending) (+ 1 brackets) result)))
|
|
((#\] . rest)
|
|
(cond ((zero? brackets)
|
|
(error "unexpected closing bracket" str))
|
|
((= 1 brackets)
|
|
(loop rest '() 0
|
|
(cons (parse-bracket (reverse pending)) result)))
|
|
(else
|
|
(loop rest (cons #\] pending) (- brackets 1) result))))
|
|
((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-sglob'."
|
|
(let loop ((pattern pattern)
|
|
(str str))
|
|
(match pattern
|
|
((? string? literal)
|
|
(string=? literal str))
|
|
(()
|
|
(string-null? str))
|
|
(('*)
|
|
#t)
|
|
(('* suffix . rest)
|
|
(match (string-contains str suffix)
|
|
(#f #f)
|
|
(index (loop rest
|
|
(string-drop str
|
|
(+ index (string-length suffix)))))))
|
|
(((? char-set? cs) . rest)
|
|
(and (>= (string-length str) 1)
|
|
(let ((chr (string-ref str 0)))
|
|
(and (char-set-contains? cs chr)
|
|
(loop rest (string-drop str 1))))))
|
|
((prefix . rest)
|
|
(and (string-prefix? prefix str)
|
|
(loop rest (string-drop str (string-length prefix))))))))
|