From f4f3949b4eb27b4e3a3b454ea0dba17338a74040 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Mon, 24 Nov 2014 19:49:59 +0900
Subject: [PATCH] Adding Gauche's `@' pattern for named record field matching.
 Also adding the `struct' and `object' aliases for `$' and `@' respectively.

---
 lib/chibi/match/match.scm | 47 +++++++++++++++++++++++++++++++++++++--
 tests/match-tests.scm     | 18 ++++++++++++++-
 2 files changed, 62 insertions(+), 3 deletions(-)

diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm
index 67b04760..d3335bd6 100644
--- a/lib/chibi/match/match.scm
+++ b/lib/chibi/match/match.scm
@@ -164,6 +164,21 @@
 ;;>     (($ employee n t) (list t n))))
 ;;> }
 
+;;> For records with more fields it can be helpful to match them by
+;;> name rather than position.  For this you can use the \scheme{@}
+;;> operator, originally a Gauche extension:
+
+;;> \example{
+;;> (let ()
+;;>   (define-record-type employee
+;;>     (make-employee name title)
+;;>     employee?
+;;>     (name get-name)
+;;>     (title get-title))
+;;>   (match (make-employee "Bob" "Doctor")
+;;>     ((@ employee (title t) (name n)) (list t n))))
+;;> }
+
 ;;> The \scheme{set!} and \scheme{get!} operators are used to bind an
 ;;> identifier to the setter and getter of a field, respectively.  The
 ;;> setter is a procedure of one argument, which mutates the field to
@@ -212,6 +227,7 @@
 ;; performance can be found at
 ;;   http://synthcode.com/scheme/match-cond-expand.scm
 ;;
+;; 2014/11/24 - adding Gauche's `@' pattern for named record field matching
 ;; 2012/12/26 - wrapping match-let&co body in lexical closure
 ;; 2012/11/28 - fixing typo s/vetor/vector in largely unused set! code
 ;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
@@ -333,7 +349,7 @@
 ;; pattern so far.
 
 (define-syntax match-two
-  (syntax-rules (_ ___ ..1 *** quote quasiquote ? $ = and or not set! get!)
+  (syntax-rules (_ ___ ..1 *** quote quasiquote ? $ struct @ object = and or not set! get!)
     ((match-two v () g+s (sk ...) fk i)
      (if (null? v) (sk ... i) fk))
     ((match-two v (quote p) g+s (sk ...) fk i)
@@ -377,6 +393,18 @@
      (if (is-a? v rec)
          (match-record-refs v rec 0 (p ...) g+s sk fk i)
          fk))
+    ((match-two v (struct rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-refs v rec 0 (p ...) g+s sk fk i)
+         fk))
+    ((match-two v (@ rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-named-refs v rec (p ...) g+s sk fk i)
+         fk))
+    ((match-two v (object rec p ...) g+s sk fk i)
+     (if (is-a? v rec)
+         (match-record-named-refs v rec (p ...) g+s sk fk i)
+         fk))
     ((match-two v (p . q) g+s sk fk i)
      (if (pair? v)
          (let ((w (car v)) (x (cdr v)))
@@ -688,6 +716,15 @@
     ((_ v rec n () g+s (sk ...) fk i)
      (sk ... i))))
 
+(define-syntax match-record-named-refs
+  (syntax-rules ()
+    ((_ v rec ((f p) . q) g+s sk fk i)
+     (let ((w (slot-ref rec v 'f)))
+       (match-one w p ((slot-ref rec v 'f) (slot-set! rec v 'f))
+                  (match-record-named-refs v rec q g+s sk fk) fk i)))
+    ((_ v rec () g+s (sk ...) fk i)
+     (sk ... i))))
+
 ;; Extract all identifiers in a pattern.  A little more complicated
 ;; than just looking for symbols, we need to ignore special keywords
 ;; and non-pattern forms (such as the predicate expression in ?
@@ -701,11 +738,17 @@
 ;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
 
 (define-syntax match-extract-vars
-  (syntax-rules (_ ___ ..1 *** ? $ = quote quasiquote and or not get! set!)
+  (syntax-rules (_ ___ ..1 *** ? $ struct @ object = quote quasiquote and or not get! set!)
     ((match-extract-vars (? pred . p) . x)
      (match-extract-vars p . x))
     ((match-extract-vars ($ rec . p) . x)
      (match-extract-vars p . x))
+    ((match-extract-vars (struct rec . p) . x)
+     (match-extract-vars p . x))
+    ((match-extract-vars (@ rec (f p) ...) . x)
+     (match-extract-vars (p ...) . x))
+    ((match-extract-vars (object rec (f p) ...) . x)
+     (match-extract-vars (p ...) . x))
     ((match-extract-vars (= proc p) . x)
      (match-extract-vars p . x))
     ((match-extract-vars (quote x) (k ...) i v)
diff --git a/tests/match-tests.scm b/tests/match-tests.scm
index a9500e19..f4c688e8 100644
--- a/tests/match-tests.scm
+++ b/tests/match-tests.scm
@@ -1,6 +1,6 @@
 
 (cond-expand
- (modules (import (chibi match) (only (chibi test) test-begin test test-end)))
+ (modules (import (chibi match) (srfi 9) (only (chibi test) test-begin test test-end)))
  (else (load "lib/chibi/match/match.scm")))
 
 (test-begin "match")
@@ -166,4 +166,20 @@
       (((and x (? symbol?)) ..1) x)
       (else #f)))
 
+(define-record-type Point
+  (make-point x y)
+  point?
+  (x point-x point-x-set!)
+  (y point-y point-y-set!))
+
+(test "record positional"
+    '(1 0)
+  (match (make-point 0 1)
+    (($ Point x y) (list y x))))
+
+(test "record named"
+    '(1 0)
+  (match (make-point 0 1)
+    ((@ Point (x x) (y y)) (list y x))))
+
 (test-end)