Added unstable/cce/match macros to unstable/match.

collects/tests/unstable/match.rkt

@@ -0,0 +1,24 @@
+#lang racket
+
+(require unstable/match rackunit rackunit/text-ui "helpers.rkt")
+
+(run-tests
+ (test-suite "match.ss"
+   (test-suite "match?"
+     (test
+      (check-true (match? (list 1 2 3)
+                    (list a b c)
+                    (vector x y z))))
+     (test
+      (check-true (match? (vector 1 2 3)
+                    (list a b c)
+                    (vector x y z))))
+     (test
+      (check-false (match? (+ 1 2 3)
+                     (list a b c)
+                     (vector x y z)))))
+   (test-suite "as"
+     (test
+      (match (list 1 2 3)
+        [(as ([a 0]) (list b c d)) (list a b c d)])
+      (list 0 1 2 3)))))

collects/unstable/cce/match.ss

@@ -1,127 +0,0 @@
-#lang scheme
-(require
- (for-syntax scheme/match
-             scheme/struct-info
-             unstable/function
-             "define.ss"
-             "syntax.ss"))
-
-(define-syntax-rule (match? e p ...)
-  (match e [p #t] ... [_ #f]))
-
-(define-syntax (define-struct-pattern stx)
-  (parameterize ([current-syntax stx])
-    (syntax-case stx ()
-      [(_ pattern-name struct-name)
-       (block
-
-        (define pattern-id #'pattern-name)
-        (define struct-id #'struct-name)
-
-        (unless (identifier? pattern-id)
-          (syntax-error pattern-id "expected an identifier"))
-
-        (unless (identifier? struct-id)
-          (syntax-error struct-id "expected an identifier"))
-
-        (define struct-info (syntax-local-value struct-id))
-
-        (unless (struct-info? struct-info)
-          (syntax-error struct-id "expected a struct name"))
-
-        (match (extract-struct-info struct-info)
-          [(list type-id
-                 constructor-id
-                 predicate-id
-                 accessor-ids
-                 mutator-ids
-                 super-id)
-           (with-syntax ([make constructor-id]
-                         [(p ...) (generate-temporaries accessor-ids)])
-             (syntax/loc stx
-               (define-match-expander pattern-name
-                 (syntax-rules ()
-                   [(_ p ...) (struct struct-name [p ...])])
-                 (redirect-transformer #'make))))]))])))
-
-(define-for-syntax (get-struct-info id)
-  (block
-
-   (define (fail)
-     (syntax-error id "expected a structure name"))
-
-   (define value
-     (syntax-local-value id fail))
-
-   (unless (struct-info? value) (fail))
-
-   (extract-struct-info value)))
-
-(define-for-syntax (struct-match-expander stx)
-  (parameterize ([current-syntax stx])
-    (syntax-case stx ()
-      [(_ s f ...)
-       (match (get-struct-info #'s)
-         [(list _
-                _
-                (? identifier? pred)
-                (list-rest (? identifier? rev-gets) ... (or (list) (list #f)))
-                _
-                _)
-          (let* ([n-patterns (length (syntax-list f ...))]
-                 [n-fields (length rev-gets)])
-            (unless (= n-patterns n-fields)
-              (syntax-error #'s
-                            "got ~a patterns for ~a fields of ~a"
-                            n-patterns n-fields (syntax-e #'s))))
-          (with-syntax ([pred? pred]
-                        [(get ...) (reverse rev-gets)])
-            (syntax/loc stx
-              (and (? pred?) (app get f) ...)))]
-         [_
-          (syntax-error
-           #'s
-           "expected a structure name with predicate and ~a fields; got ~a"
-           (length (syntax-list f ...))
-           (syntax-e #'s))])])))
-
-(define-for-syntax (struct-make-expander stx)
-  (parameterize ([current-syntax stx])
-    (syntax-case stx ()
-      [(_ s f ...)
-       (match (get-struct-info #'s)
-         [(list _
-                (? identifier? make)
-                _
-                rev-gets
-                _
-                _)
-          (match rev-gets
-            [(list (? identifier?) ...)
-             (let* ([n-fields (length rev-gets)]
-                    [n-exprs (length (syntax-list f ...))])
-               (unless (= n-exprs n-fields)
-                 (syntax-error
-                  #'s
-                  "got ~a arguments for ~a fields in structure ~a"
-                  n-exprs n-fields (syntax-e #'s))))]
-            [_ (void)])
-          (with-syntax ([mk make])
-            (syntax/loc stx
-              (mk f ...)))]
-         [_
-          (syntax-error
-           #'s
-           "expected a structure name with constructor; got ~a"
-           (syntax-e #'s))])])))
-
-(define-match-expander $
-  ;; define-match-expander is STUPIDLY non-uniform about variable expressions
-  (identity struct-match-expander)
-  (identity struct-make-expander))
-
-(define-match-expander as
-  (syntax-rules ()
-    [(as ([x e] ...) p ...) (and (app (lambda (y) e) x) ... p ...)]))
-
-(provide match? define-struct-pattern $ as)

collects/unstable/cce/reference/manual.scrbl

@@ -23,8 +23,6 @@
 @include-section["syntax.scrbl"]
 @include-section["define.scrbl"]
 
-@include-section["match.scrbl"]
-
 @include-section["class.scrbl"]
 
 @include-section["contract.scrbl"]

collects/unstable/cce/reference/match.scrbl

@@ -1,81 +0,0 @@
-#lang scribble/doc
-@(require scribble/manual
-          scribble/eval
-          "../scribble.ss"
-          "eval.ss")
-@(require (for-label scheme unstable/cce/match))
-
-@title[#:style 'quiet #:tag "cce-match"]{Pattern Matching}
-
-@defmodule[unstable/cce/match]
-
-This module provides tools for pattern matching with @scheme[match].
-
-@defform[(match? val-expr pat ...)]{
-
-Returns @scheme[#t] if the result of @scheme[val-expr] matches any of
-@scheme[pat], and returns @scheme[#f] otherwise.
-
-@defexamples[
-#:eval (evaluator 'unstable/cce/match)
-(match? (list 1 2 3)
-  (list a b c)
-  (vector x y z))
-(match? (vector 1 2 3)
-  (list a b c)
-  (vector x y z))
-(match? (+ 1 2 3)
-  (list a b c)
-  (vector x y z))
-]
-
-}
-
-@defform[(define-struct-pattern pat-id struct-id)]{
-
-Defines @scheme[pat-id] as a match expander that takes one pattern argument per
-field of the structure described by @scheme[struct-id].  The resulting match
-expander recognizes instances of the structure and matches their fields against
-the corresponding patterns.
-
-@defexamples[
-#:eval (evaluator 'unstable/cce/match)
-(define-struct pair [a b] #:transparent)
-(define-struct-pattern both pair)
-(match (make-pair 'left 'right)
-  [(both a b) (list a b)])
-]
-
-}
-
-@defform[(as ([lhs-id rhs-expr] ...) pat ...)]{
-
-As a match expander, binds each @scheme[lhs-id] as a pattern variable with the
-result value of @scheme[rhs-expr], and continues matching each subsequent
-@scheme[pat].
-
-@defexamples[
-#:eval (evaluator 'unstable/cce/match)
-(match (list 1 2 3)
-  [(as ([a 0]) (list b c d)) (list a b c d)])
-]
-
-}
-
-@defform*[[($ struct-id expr ...) ($ struct-id pat ...)]]{
-
-As an expression, constructs an instance of the structure described by
-@scheme[struct-id] with fields specified by each @scheme[expr].
-
-As a match expander, matches instances of the structure described by
-@scheme[struct-id] with fields matched by each @scheme[pat].
-
-@defexamples[
-#:eval (evaluator 'unstable/cce/match)
-(define-struct pair [a b] #:transparent)
-($ pair 1 2)
-(match ($ pair 1 2)
-  [($ pair a b) (list a b)])
-]
-
-}

collects/unstable/cce/test/test-main.ss

@@ -8,7 +8,6 @@
          "test-dict.ss"
          "test-exn.ss"
          "test-hash.ss"
-         "test-match.ss"
          "test-planet.ss"
          "test-port.ss"
          "test-queue.ss"
@@ -30,7 +29,6 @@
    dict-suite
    exn-suite
    hash-suite
-   match-suite
    planet-suite
    port-suite
    queue-suite

collects/unstable/cce/test/test-match.ss

@@ -1,45 +0,0 @@
-#lang scheme
-
-(require "checks.ss"
-         "../match.ss")
-
-(provide match-suite)
-
-(define match-suite
-  (test-suite "match.ss"
-    (test-suite "match?"
-      (test
-       (check-true (match? (list 1 2 3)
-                     (list a b c)
-                     (vector x y z))))
-      (test
-       (check-true (match? (vector 1 2 3)
-                     (list a b c)
-                     (vector x y z))))
-      (test
-       (check-false (match? (+ 1 2 3)
-                      (list a b c)
-                      (vector x y z)))))
-    (test-suite "define-struct-pattern"
-      (test
-       (let ()
-         (define-struct pair [a b] #:transparent)
-         (define-struct-pattern both pair)
-         (check-equal?
-          (match (make-pair 1 2)
-            [(both a b) (list a b)])
-          (list 1 2)))))
-    (test-suite "as"
-      (test
-       (match (list 1 2 3)
-         [(as ([a 0]) (list b c d)) (list a b c d)])
-       (list 0 1 2 3)))
-    (test-suite "$"
-      (test
-       (let ()
-         (define-struct pair [a b] #:transparent)
-         (check-equal? ($ pair 1 2) (make-pair 1 2))
-         (check-equal?
-          (match ($ pair 1 2)
-            [($ pair a b) (list a b)])
-          (list 1 2)))))))

collects/unstable/match.rkt

@@ -2,7 +2,7 @@
 
 (require racket/match (for-syntax racket/base))
 
-(provide ==)
+(provide == match? as)
 
 (define-match-expander
   ==
@@ -11,3 +11,10 @@
       [(_ val comp)
        #'(? (lambda (x) (comp val x)))]
       [(_ val) #'(== val equal?)])))
+
+(define-syntax-rule (match? e p ...)
+  (match e [p #t] ... [_ #f]))
+
+(define-match-expander as
+  (syntax-rules ()
+    [(as ([x e] ...) p ...) (and (app (lambda (y) e) x) ... p ...)]))

collects/unstable/scribblings/match.scrbl

@@ -1,12 +1,10 @@
-#lang scribble/doc
+#lang scribble/manual
-@(require scribble/base
+@(require scribble/eval	  
-          scribble/manual
-          scribble/eval	  
 	  "utils.rkt"
-         (for-label unstable/match
+          (for-label unstable/match
-		    racket/match
+                     racket/match
-                    racket/contract
+                     racket/contract
-                    racket/base))
+                     racket/base))
 
 @(define the-eval (make-base-eval))
 @(the-eval '(require unstable/match racket/match))
@@ -34,4 +32,40 @@ not provided, it defaults to @racket[equal?].
   [(list 1 2 (== 3 =)) 'yes]
   [_ 'no])
 ]
-}
+}
+
+@addition[@author+email["Carl Eastlund" "cce@racket-lang.org"]]
+
+@defform[(match? val-expr pat ...)]{
+
+Returns @scheme[#t] if the result of @scheme[val-expr] matches any of
+@scheme[pat], and returns @scheme[#f] otherwise.
+
+@defexamples[
+#:eval (eval/require 'racket/match 'unstable/match)
+(match? (list 1 2 3)
+  (list a b c)
+  (vector x y z))
+(match? (vector 1 2 3)
+  (list a b c)
+  (vector x y z))
+(match? (+ 1 2 3)
+  (list a b c)
+  (vector x y z))
+]
+
+}
+
+@defform[(as ([lhs-id rhs-expr] ...) pat ...)]{
+
+As a match expander, binds each @scheme[lhs-id] as a pattern variable with the
+result value of @scheme[rhs-expr], and continues matching each subsequent
+@scheme[pat].
+
+@defexamples[
+#:eval (eval/require 'racket/match 'unstable/match)
+(match (list 1 2 3)
+  [(as ([a 0]) (list b c d)) (list a b c d)])
+]
+
+}