Add pattern dropping procedures.

* gash/pattern.scm (string-contains-part-right): New procedure.
(pattern-drop): New procedure.
(pattern-drop-right): New procedure.
* tests/unit/pattern.scm: Test the dropping procedures.

gash/pattern.scm

@@ -26,7 +26,9 @@
   #:export (parse-pattern
             pattern-quote
             pattern-plain?
-            pattern-match?))
+            pattern-match?
+            pattern-drop
+            pattern-drop-right))
 
 (define-immutable-record-type <pattern>
   (make-pattern parts start-anchored? end-anchored?)
@@ -212,6 +214,14 @@ source string is the only string that will match it."
      ((string-starts-with-part s part i end) i)
      (else (loop (1+ i))))))
 
+(define* (string-contains-part-right s part #:optional (start 0)
+                                     (end (string-length s)))
+  (let loop ((i end))
+    (cond
+     ((< i start) #f)
+     ((string-ends-with-part s part start i) (- i (vector-length part)))
+     (else (loop (1- i))))))
+
 (define* (pattern-match? pattern str #:optional (start 0)
                          (end (string-length str))
                          #:key explicit-initial-period?)
@@ -248,3 +258,51 @@ source string is the only string that will match it."
                     (let ((start* (+ start (vector-length part))))
                       (parts-match? rest start* end-anchored?)))))
             (parts-match? parts start end-anchored?)))))
+
+(define* (pattern-drop pattern str #:key greedy?)
+  (define (match-parts parts i end-anchored?)
+    (match parts
+      (() (if (and greedy? (not end-anchored?))
+           ""
+           (substring str i)))
+      ((part . rest)
+       (match (if (and greedy? (null? rest))
+                  (string-contains-part-right str part i)
+                  (string-contains-part str part i))
+         (#f str)
+         (m (match-parts rest (+ m (vector-length part)) end-anchored?))))))
+
+  (match-let ((($ <pattern> parts start-anchored? end-anchored?) pattern))
+    (if start-anchored?
+        (match parts
+          (() str)
+          ((part . rest)
+           (if (string-starts-with-part str part)
+               (match-parts rest (vector-length part) end-anchored?)
+               str)))
+        (match-parts parts 0 end-anchored?))))
+
+(define* (pattern-drop-right pattern str #:key greedy?)
+  (define (match-parts parts i start-anchored?)
+    (match parts
+      (() (if (and greedy? (not start-anchored?))
+              ""
+              (substring str 0 i)))
+      ((part . rest)
+       (match (if (and greedy? (null? rest))
+                  (string-contains-part str part 0 i)
+                  (string-contains-part-right str part 0 i))
+         (#f str)
+         (m (match-parts rest m start-anchored?))))))
+
+  (match-let ((($ <pattern> parts start-anchored? end-anchored?) pattern))
+    (let ((strap (reverse parts)))
+      (if end-anchored?
+          (match strap
+            (() str)
+            ((part . rest)
+             (if (string-ends-with-part str part)
+                 (let ((i (- (string-length str) (vector-length part))))
+                   (match-parts rest i start-anchored?))
+                 str)))
+          (match-parts strap (string-length str) start-anchored?)))))

tests/unit/pattern.scm

@@ -185,6 +185,61 @@
 (test-assert "Character classes are not plain"
   (not (pattern-plain? (parse-pattern "[fo]o"))))
 
+
+;;; Dropping
+
+;; Dropping on the left.
+
+(test-equal "Drops by a pattern"
+  "obar"
+  (pattern-drop (parse-pattern "*o") "foobar"))
+
+(test-equal "Drops by a pattern (greedy)"
+  "bar"
+  (pattern-drop (parse-pattern "*o") "foobar" #:greedy? #t))
+
+(test-equal "Does not drop by an empty pattern"
+  "foobar"
+  (pattern-drop (parse-pattern "") "foobar"))
+
+(test-equal "Does not drop by a non-matching pattern"
+  "foobar"
+  (pattern-drop (parse-pattern "*x*") "foobar"))
+
+(test-equal "Drops by a pattern ending with a wildcard"
+  "oobar"
+  (pattern-drop (parse-pattern "f*") "foobar"))
+
+(test-equal "Drops by a pattern ending with a wildcard (greedy)"
+  ""
+  (pattern-drop (parse-pattern "f*") "foobar" #:greedy? #t))
+
+;; Dropping on the right.
+
+(test-equal "Drops-right by a pattern"
+  "buz"
+  (pattern-drop-right (parse-pattern "z*") "buzzy"))
+
+(test-equal "Drops-right by a pattern (greedy)"
+  "bu"
+  (pattern-drop-right (parse-pattern "z*") "buzzy" #:greedy? #t))
+
+(test-equal "Does not drop-right by an empty pattern"
+  "buzzy"
+  (pattern-drop-right (parse-pattern "") "buzzy"))
+
+(test-equal "Does not drop-right by a non-matching pattern"
+  "buzzy"
+  (pattern-drop-right (parse-pattern "*x*") "buzzy"))
+
+(test-equal "Drops-right by a pattern starting with a wildcard"
+  "buzz"
+  (pattern-drop-right (parse-pattern "*y") "buzzy"))
+
+(test-equal "Drops-right by a pattern starting with a wildcard (greedy)"
+  ""
+  (pattern-drop-right (parse-pattern "*y") "buzzy" #:greedy? #t))
+
 (test-end)
 
 ;; Local Variables: