diff --git a/collects/tests/unstable/match.rkt b/collects/tests/unstable/match.rkt new file mode 100644 index 0000000000..a356b1daa1 --- /dev/null +++ b/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))))) diff --git a/collects/unstable/cce/match.ss b/collects/unstable/cce/match.ss deleted file mode 100644 index 026130d351..0000000000 --- a/collects/unstable/cce/match.ss +++ /dev/null @@ -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) diff --git a/collects/unstable/cce/reference/manual.scrbl b/collects/unstable/cce/reference/manual.scrbl index 49eb72e379..f278f78a8d 100644 --- a/collects/unstable/cce/reference/manual.scrbl +++ b/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"] diff --git a/collects/unstable/cce/reference/match.scrbl b/collects/unstable/cce/reference/match.scrbl deleted file mode 100644 index 7b15321b49..0000000000 --- a/collects/unstable/cce/reference/match.scrbl +++ /dev/null @@ -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)]) -] - -} diff --git a/collects/unstable/cce/test/test-main.ss b/collects/unstable/cce/test/test-main.ss index 259afccb4c..1c9859ba34 100644 --- a/collects/unstable/cce/test/test-main.ss +++ 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 diff --git a/collects/unstable/cce/test/test-match.ss b/collects/unstable/cce/test/test-match.ss deleted file mode 100644 index 8bc11a5a11..0000000000 --- a/collects/unstable/cce/test/test-match.ss +++ /dev/null @@ -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))))))) diff --git a/collects/unstable/match.rkt b/collects/unstable/match.rkt index 45887f3b49..2f07528e46 100644 --- a/collects/unstable/match.rkt +++ b/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 ...)])) diff --git a/collects/unstable/scribblings/match.scrbl b/collects/unstable/scribblings/match.scrbl index 8a7aa59990..12a4fde213 100644 --- a/collects/unstable/scribblings/match.scrbl +++ b/collects/unstable/scribblings/match.scrbl @@ -1,12 +1,10 @@ -#lang scribble/doc -@(require scribble/base - scribble/manual - scribble/eval +#lang scribble/manual +@(require scribble/eval "utils.rkt" - (for-label unstable/match - racket/match - racket/contract - racket/base)) + (for-label unstable/match + racket/match + racket/contract + 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]) ] -} \ No newline at end of file +} + +@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)]) +] + +}