You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

137 lines
4.5 KiB

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <>
;;; 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
;;; 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 <>.
(define-module (guix glob)
#:use-module (ice-9 match)
#:export (string->sglob
;;; 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))
`(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
(((? 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)
(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)))
(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)
(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)))
((('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
(let loop ((pattern pattern)
(str str))
(match pattern
((? string? literal)
(string=? literal str))
(string-null? str))
(('* 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))))))))