Use a record type for patterns.
* gash/compat/srfi-43.scm: New file. * Makefile.am: Add it. * gash/pattern.scm (<pattern>): New record type. (parse-part): New procedure. (parse-pattern): Return a '<pattern>'. (pattern-plain?, pattern-match?): Accept a '<pattern>'. (string-starts-with-part, string-ends-with-part, string-contains-part): Treat 'part' as a vector.
This commit is contained in:
Timothy Sample
parent
a009118efb
commit
7c8ddd7a43
|
|
@ -60,6 +60,7 @@ SOURCES = \
|
|||
gash/built-ins/utils.scm \
|
||||
gash/built-ins.scm \
|
||||
gash/compat/hash-table.scm \
|
||||
gash/compat/srfi-43.scm \
|
||||
gash/compat/textual-ports.scm \
|
||||
gash/compat.scm \
|
||||
gash/config.scm \
|
||||
|
|
|
|||
|
|
@ -0,0 +1,39 @@
|
|||
;;; Gash -- Guile As SHell
|
||||
;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com>
|
||||
;;;
|
||||
;;; This file is part of Gash.
|
||||
;;;
|
||||
;;; Gash 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.
|
||||
;;;
|
||||
;;; Gash 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 Gash. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (gash compat srfi-43)
|
||||
#:use-module (gash compat))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; The '(srfi srfi-43)' module was introduced into Guile in version
|
||||
;;; 2.0.10, so we provide a shim.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(if-guile-version-below (2 0 10)
|
||||
(begin
|
||||
;; We only need the single vector version.
|
||||
(define-public (vector-every pred? vec)
|
||||
(let loop ((i 0) (value #t))
|
||||
(if (< i (vector-length vec))
|
||||
(and value (loop (1+ i) (pred? (vector-ref vec i))))
|
||||
value))))
|
||||
(begin
|
||||
(use-modules (srfi srfi-43))
|
||||
(re-export vector-every)))
|
||||
183
gash/pattern.scm
183
gash/pattern.scm
|
|
@ -1,5 +1,5 @@
|
|||
;;; Gash -- Guile As SHell
|
||||
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
|
||||
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
|
||||
;;;
|
||||
;;; This file is part of Gash.
|
||||
;;;
|
||||
|
|
@ -20,12 +20,21 @@
|
|||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 receive)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9 gnu)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (gash compat srfi-43)
|
||||
#:export (parse-pattern
|
||||
pattern-quote
|
||||
pattern-plain?
|
||||
pattern-match?))
|
||||
|
||||
(define-immutable-record-type <pattern>
|
||||
(make-pattern parts start-anchored? end-anchored?)
|
||||
pattern?
|
||||
(parts pattern-parts)
|
||||
(start-anchored? pattern-start-anchored?)
|
||||
(end-anchored? pattern-end-anchored?))
|
||||
|
||||
(define* (parse-rdelim s1 s2 #:optional (start 0) (end (string-length s1)))
|
||||
|
||||
(define (not-backslash? chr) (not (char=? chr #\\)))
|
||||
|
|
@ -119,28 +128,38 @@
|
|||
(values result length)
|
||||
(values (char-set-complement! result) (1+ length))))))
|
||||
|
||||
(define* (parse-pattern s #:optional (start 0) (end (string-length s)))
|
||||
"Parse the string @var{s} as a pattern."
|
||||
(let loop ((i start) (parts '()) (acc '()))
|
||||
(define* (parse-part s #:optional (start 0) (end (string-length s)))
|
||||
(let loop ((i start) (acc '()))
|
||||
(match (and (< i end) (string-ref s i))
|
||||
(#f (if (null? acc)
|
||||
(reverse! parts)
|
||||
(reverse! (cons (reverse! acc) parts))))
|
||||
(#\* (if (null? acc)
|
||||
(loop (1+ i) (cons '* parts) '())
|
||||
(loop (1+ i) (cons* '* (reverse! acc) parts) '())))
|
||||
(#\? (loop (1+ i) parts (cons '? acc)))
|
||||
(#f (match acc
|
||||
(() (values #f 0))
|
||||
(_ (values (list->vector (reverse! acc)) (- i start)))))
|
||||
(#\* (match acc
|
||||
(() (values '* 1))
|
||||
(_ (values (list->vector (reverse! acc)) (- i start)))))
|
||||
(#\? (loop (1+ i) (cons char-set:full acc)))
|
||||
(#\[ (if (< (1+ i) end)
|
||||
(receive (result length)
|
||||
(parse-bracket-expression s (1+ i) end)
|
||||
(if result
|
||||
(loop (+ i length 1) parts (cons result acc))
|
||||
(loop (1+ i) parts (cons #\[ acc))))
|
||||
(loop (1+ i) parts (cons #\[ acc))))
|
||||
(loop (+ i length 1) (cons result acc))
|
||||
(loop (1+ i) (cons #\[ acc))))
|
||||
(loop (1+ i) (cons #\[ acc))))
|
||||
(#\\ (if (< (1+ i) end)
|
||||
(loop (+ i 2) parts (cons (string-ref s (1+ i)) acc))
|
||||
(loop (1+ i) parts acc)))
|
||||
(chr (loop (1+ i) parts (cons chr acc))))))
|
||||
(loop (+ i 2) (cons (string-ref s (1+ i)) acc))
|
||||
(loop (1+ i) acc)))
|
||||
(chr (loop (1+ i) (cons chr acc))))))
|
||||
|
||||
(define* (parse-pattern s #:optional (start 0) (end (string-length s)))
|
||||
"Parse the string @var{s} as a pattern."
|
||||
(let loop ((i start) (parts '()) (start-anchored? #t) (end-anchored? #t))
|
||||
(receive (part length) (parse-part s i end)
|
||||
(match part
|
||||
(#f (make-pattern (reverse! parts) start-anchored? end-anchored?))
|
||||
('* (match parts
|
||||
(() (loop (+ i length) '() #f #f))
|
||||
(_ (loop (+ i length) parts start-anchored? #f))))
|
||||
(_ (loop (+ i length) (cons part parts) start-anchored? #t))))))
|
||||
|
||||
(define pattern-quote
|
||||
(let ((specials '(#\\ #\* #\? #\[ #\] #\! #\-)))
|
||||
|
|
@ -159,95 +178,73 @@ them are treated specially when @var{s} is interpreted as a pattern."
|
|||
"Check if @var{pattern} free of special pattern constructions like
|
||||
asterisks and bracket expressions. If a pattern is ``plain'' its
|
||||
source string is the only string that will match it."
|
||||
(every (match-lambda
|
||||
('* #f)
|
||||
(parts (every (match-lambda
|
||||
((or (? char?) (? string?)) #t)
|
||||
(_ #f))
|
||||
parts)))
|
||||
pattern))
|
||||
(and (pattern-start-anchored? pattern)
|
||||
(pattern-end-anchored? pattern)
|
||||
(match (pattern-parts pattern)
|
||||
(() #t)
|
||||
((part) (vector-every char? part))
|
||||
(_ #f))))
|
||||
|
||||
(define* (string-starts-with-part s part #:optional (start 0)
|
||||
(end (string-length s)))
|
||||
(let loop ((part part) (i start))
|
||||
(match (and (< i end) part)
|
||||
(#f (match part
|
||||
(() (- i start))
|
||||
(((? string? s2) . rest)
|
||||
(and (string-null? s2)
|
||||
(loop rest i)))
|
||||
(_ #f)))
|
||||
(() (- i start))
|
||||
(('? . rest) (loop rest (1+ i)))
|
||||
(((? string? s2) . rest)
|
||||
(and (string-prefix? s2 s 0 (string-length s2) i end)
|
||||
(loop rest (+ i (string-length s2)))))
|
||||
(((? char? chr) . rest)
|
||||
(and (char=? (string-ref s i) chr)
|
||||
(loop rest (1+ i))))
|
||||
(((? char-set? cs) . rest)
|
||||
(and (char-set-contains? cs (string-ref s i))
|
||||
(loop rest (1+ i)))))))
|
||||
|
||||
(define (pattern-part-length part)
|
||||
(let loop ((part part) (length 0))
|
||||
(match part
|
||||
(() length)
|
||||
(((? string? str) . rest) (loop rest (+ length (string-length str))))
|
||||
((first . rest) (loop rest (1+ length))))))
|
||||
(and (<= (vector-length part) (- end start))
|
||||
(let loop ((i 0) (j start))
|
||||
(match (and (< i (vector-length part)) (vector-ref part i))
|
||||
(#f #t)
|
||||
((? char? chr)
|
||||
(and (char=? (string-ref s j) chr)
|
||||
(loop (1+ i) (1+ j))))
|
||||
((? char-set? cs)
|
||||
(and (char-set-contains? cs (string-ref s j))
|
||||
(loop (1+ i) (1+ j))))))))
|
||||
|
||||
(define* (string-ends-with-part s part #:optional (start 0)
|
||||
(end (string-length s)))
|
||||
(let ((start* (- end (pattern-part-length part))))
|
||||
(let ((start* (- end (vector-length part))))
|
||||
(and (>= start* start)
|
||||
(string-starts-with-part s part start* end))))
|
||||
|
||||
(define* (string-contains-part s part #:optional (start 0)
|
||||
(end (string-length s)))
|
||||
(let loop ((part part) (i start))
|
||||
(match part
|
||||
(() (cons start (- i start)))
|
||||
(('? . rest) (loop rest (1+ i)))
|
||||
(((? string? s2) . rest)
|
||||
(and=> (string-contains s s2 i end)
|
||||
(lambda (index)
|
||||
(or (and=> (string-starts-with-part s part index end)
|
||||
(cut cons index <>))
|
||||
(loop part (1+ index))))))
|
||||
(((or (? char? cp) (? char-set? cp)) . rest)
|
||||
(and=> (string-index s cp i end)
|
||||
(lambda (index)
|
||||
(or (and=> (string-starts-with-part s part index end)
|
||||
(cut cons index <>))
|
||||
(loop part (1+ index)))))))))
|
||||
(let loop ((i start))
|
||||
(cond
|
||||
((>= i end) #f)
|
||||
((string-starts-with-part s part i end) i)
|
||||
(else (loop (1+ i))))))
|
||||
|
||||
(define* (pattern-match? pattern str #:optional (start 0)
|
||||
(end (string-length str))
|
||||
#:key explicit-initial-period?)
|
||||
"Check if @var{str} matches @var{pattern}."
|
||||
(if (and explicit-initial-period?
|
||||
(< start end)
|
||||
(char=? (string-ref str start) #\.))
|
||||
(match pattern
|
||||
(((#\. . _) . _)
|
||||
(pattern-match? pattern str start end
|
||||
#:explicit-initial-period? #f))
|
||||
((((? string? s) . _) ._)
|
||||
(and (string-prefix? "." s)
|
||||
(pattern-match? pattern str start end
|
||||
#:explicit-initial-period? #f)))
|
||||
(_ #f))
|
||||
(let loop ((pattern pattern) (i start))
|
||||
(match pattern
|
||||
(() (= i end))
|
||||
(('*) #t)
|
||||
(('* (? pair? part)) (string-ends-with-part str part i end))
|
||||
(('* (? pair? part) . rest)
|
||||
(and=> (string-contains-part str part i end)
|
||||
(match-lambda
|
||||
((match-index . match-length)
|
||||
(loop rest (+ match-index match-length))))))
|
||||
(((? pair? part) . rest)
|
||||
(and=> (string-starts-with-part str part i end)
|
||||
(lambda (length)
|
||||
(loop rest (+ i length)))))))))
|
||||
|
||||
(define (parts-match? parts start end-anchored?)
|
||||
(match parts
|
||||
(() (or (not end-anchored?) (= start end)))
|
||||
((part)
|
||||
(if end-anchored?
|
||||
(string-ends-with-part str part start end)
|
||||
(string-contains-part str part start end)))
|
||||
((part . rest)
|
||||
(and=> (string-contains-part str part start end)
|
||||
(lambda (m)
|
||||
(let ((start* (+ m (vector-length part))))
|
||||
(parts-match? rest start* end-anchored?)))))))
|
||||
|
||||
(match-let ((($ <pattern> parts start-anchored? end-anchored?) pattern))
|
||||
(if (and explicit-initial-period?
|
||||
(< start end)
|
||||
(char=? (string-ref str start) #\.))
|
||||
(and start-anchored?
|
||||
(match parts
|
||||
((#(#\. _ ...) . _)
|
||||
(pattern-match? pattern str start end
|
||||
#:explicit-initial-period? #f))
|
||||
(_ #f)))
|
||||
(if start-anchored?
|
||||
(match parts
|
||||
(() (= start end))
|
||||
((part . rest)
|
||||
(and (string-starts-with-part str part start end)
|
||||
(let ((start* (+ start (vector-length part))))
|
||||
(parts-match? rest start* end-anchored?)))))
|
||||
(parts-match? parts start end-anchored?)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue