Added unstable/cce/match macros to unstable/match.
This commit is contained in:
Carl Eastlund
parent
6bcf77fe65
commit
a22a1a4c15
24
collects/tests/unstable/match.rkt
Normal file
24
collects/tests/unstable/match.rkt
Normal file
|
|
@ -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)))))
|
||||
|
|
@ -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)
|
||||
|
|
@ -23,8 +23,6 @@
|
|||
@include-section["syntax.scrbl"]
|
||||
@include-section["define.scrbl"]
|
||||
|
||||
@include-section["match.scrbl"]
|
||||
|
||||
@include-section["class.scrbl"]
|
||||
|
||||
@include-section["contract.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)])
|
||||
]
|
||||
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
@ -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 ...)]))
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
]
|
||||
}
|
||||
}
|
||||
|
||||
@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)])
|
||||
]
|
||||
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user