use racket. add list-match utility

collects/honu/core/private/util.rkt

@@ -1,15 +1,18 @@
-#lang scheme
+#lang racket/base
 
-(provide (except-out (all-defined-out) test))
-(require "debug.rkt")
+(provide (except-out (all-defined-out) test-delimiter))
+(require "debug.rkt"
+         tests/eli-tester
+         racket/match
+         (for-syntax racket/base)
+         syntax/stx
+         racket/list)
 
 #;
 (provide delim-identifier=?
          extract-until
          call-values)
 
-(require syntax/stx
-         scheme/list)
 
 (define (delim-identifier=? a b)
   (eq? (syntax-e a) (syntax-e b)))
@@ -50,7 +53,7 @@
 (define (drop-last lst)
   (take lst (sub1 (length lst))))
 
-(define (test)
+(define (test-delimiter)
   (let* ([original #'(a b c d e)]
          [delimiter #'c]
          [expected-before #'(a b)]
@@ -71,4 +74,41 @@
         (debug " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit))
         ))))
 
+#;
 (test)
+
+;; better version of caddadadr-type functions
+(define-syntax (list-match stx)
+  (define (convert-pattern pattern)
+    (syntax-case pattern ()
+      [(x ...) (with-syntax ([(x* ...) (map convert-pattern (syntax->list #'(x ...)))])
+                 #'(list x* ...))]
+      [x #'x]))
+  (define (extract-variable pattern)
+    (define (non-wildcard-identifier? x)
+      (and (identifier? x)
+           (not (eq? (syntax-e x) '_))))
+    (syntax-case pattern ()
+      [(a x ...)
+       (if (non-wildcard-identifier? #'a)
+         #'a
+         (or (extract-variable #'a)
+             (extract-variable #'(x ...))))]
+      [x (if (non-wildcard-identifier? #'x)
+           #'x
+           #f)]))
+  (syntax-case stx ()
+    [(_ pattern expression)
+     (with-syntax ([match-pattern (convert-pattern #'pattern)]
+                   [match-variable (extract-variable #'pattern)])
+       #'(match expression
+           [match-pattern match-variable]))]))
+
+#;
+(test
+  (list-match a '(1 2 3)) => '(1 2 3)
+  (list-match (a _ ...) '(1 2 3)) => 1
+  (list-match (_ _ a ...) '(1 2 3 4)) => '(3 4)
+  (list-match ((_ a _ ...) _ ...) '((1 2 3 4) 5 6)) => 2
+  (list-match ((_ _ a _ ...) _ ...) '((7 6 5 4 3 2 1) 8 9)) => 5
+  )