diff --git a/collects/unstable/match.rkt b/collects/unstable/match.rkt index 2f07528e46..3fb84b6fba 100644 --- a/collects/unstable/match.rkt +++ b/collects/unstable/match.rkt @@ -1,8 +1,11 @@ #lang racket/base -(require racket/match (for-syntax racket/base)) +(require racket/class + racket/match + (for-syntax racket/base) + (for-syntax syntax/parse)) -(provide == match? as) +(provide == match? as object) (define-match-expander == @@ -18,3 +21,25 @@ (define-match-expander as (syntax-rules () [(as ([x e] ...) p ...) (and (app (lambda (y) e) x) ... p ...)])) + +;; Added by asumu +;; Match expander for objects from racket/class +(define-match-expander object + (λ (stx) + (define-syntax-class field + #:attributes (name pat) + (pattern + ((~datum field) + name + (~optional pat #:defaults ([pat #'name]))))) + + (syntax-parse stx + [(object f:field ...) + #'(and (? object?) + (and (? (λ (o) (field-bound? f.name o))) + (app (λ (o) (get-field f.name o)) + f.pat)) + ...)] + [(object class f:field ...) + #'(and (? (λ (o) (is-a? o class))) + (object f ...))]))) diff --git a/collects/unstable/scribblings/match.scrbl b/collects/unstable/scribblings/match.scrbl index 384e53ba08..9d84a4943e 100644 --- a/collects/unstable/scribblings/match.scrbl +++ b/collects/unstable/scribblings/match.scrbl @@ -3,7 +3,7 @@ (for-label unstable/match racket/match racket/contract racket/base)) @(define the-eval (make-base-eval)) -@(the-eval '(require racket/match unstable/match)) +@(the-eval '(require racket/class racket/match unstable/match)) @title[#:tag "match"]{Match} @@ -66,4 +66,51 @@ result value of @racket[rhs-expr], and continues matching each subsequent } +@addition[@author+email["Asumu Takikawa" "asumu@racket-lang.org"]] + +@defform/subs[ + #:literals (field) + (object maybe-class field-clause ...) + ([maybe-class + code:blank + class-expr] + [field-clause (field field-id maybe-pat)] + [maybe-pat + code:blank + pat])]{ + +A match expander that checks if the matched value is an object +and contains the fields named by the @racket[field-id]s. If +@racket[pat]s are provided, the value in each field is matched to +its corresponding @racket[pat]. If a @racket[pat] is not provided, +it defaults to the name of the field. + +If @racket[class-expr] is provided, the match expander will also +check that the supplied object is an instance of the class +that the given expression evaluates to. + +@defexamples[ +#:eval the-eval +(define point% + (class object% + (super-new) + (init-field x y))) + +(match (make-object point% 3 5) + [(object point% (field x) (field y)) + (sqrt (+ (* x x) (* y y)))]) + +(match (make-object point% 0 0) + [(object (field x (? zero?)) + (field y (? zero?))) + 'origin]) + +(match (make-object object%) + [(object (field x) (field y)) + 'ok] + [_ 'fail]) +] + +} + @close-eval[the-eval]