Commit | Line | Data |
---|---|---|
f14c933d LC |
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) | |
71e08fde LC |
21 | #:export (string->sglob |
22 | compile-sglob | |
23 | string->compiled-sglob | |
f14c933d LC |
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 | |
e914b398 | 30 | ;;; support braces, for instance. |
f14c933d LC |
31 | ;;; |
32 | ;;; Code: | |
33 | ||
e914b398 LC |
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)))) | |
f14c933d | 41 | |
71e08fde LC |
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\"." | |
f14c933d LC |
45 | (define flatten |
46 | (match-lambda | |
47 | (((? string? str)) str) | |
48 | (x x))) | |
49 | ||
e914b398 LC |
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) | |
f14c933d | 58 | (result '())) |
e914b398 | 59 | (match chars |
f14c933d | 60 | (() |
e914b398 LC |
61 | (flatten (reverse (if (null? pending) |
62 | result | |
63 | (cons-string pending result))))) | |
64 | (((and chr (or #\? #\*)) . rest) | |
65 | (let ((wildcard (match chr | |
f14c933d LC |
66 | (#\? '?) |
67 | (#\* '*)))) | |
e914b398 LC |
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))))) | |
f14c933d | 87 | |
71e08fde LC |
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 | ||
f14c933d LC |
112 | (define (glob-match? pattern str) |
113 | "Return true if STR matches PATTERN, a compiled glob pattern as returned by | |
71e08fde | 114 | 'compile-sglob'." |
f14c933d LC |
115 | (let loop ((pattern pattern) |
116 | (str str)) | |
117 | (match pattern | |
e914b398 LC |
118 | ((? string? literal) |
119 | (string=? literal str)) | |
120 | (() | |
121 | (string-null? str)) | |
122 | (('*) | |
123 | #t) | |
f14c933d LC |
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))))))) | |
71e08fde | 130 | (((? char-set? cs) . rest) |
e914b398 LC |
131 | (and (>= (string-length str) 1) |
132 | (let ((chr (string-ref str 0))) | |
71e08fde | 133 | (and (char-set-contains? cs chr) |
e914b398 | 134 | (loop rest (string-drop str 1)))))) |
f14c933d LC |
135 | ((prefix . rest) |
136 | (and (string-prefix? prefix str) | |
137 | (loop rest (string-drop str (string-length prefix)))))))) |