;;; 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))))))))