diff --git a/collects/lang/htdp-advanced.rkt b/collects/lang/htdp-advanced.rkt index 1efbb3ef90..e706c0cb8d 100644 --- a/collects/lang/htdp-advanced.rkt +++ b/collects/lang/htdp-advanced.rkt @@ -48,6 +48,7 @@ [advanced-when when] [advanced-unless unless] [advanced-case case] + [advanced-match match] [advanced-delay delay] [advanced-module-begin #%module-begin] ) diff --git a/collects/lang/posn.rkt b/collects/lang/posn.rkt index 059b534899..124263559a 100644 --- a/collects/lang/posn.rkt +++ b/collects/lang/posn.rkt @@ -4,6 +4,7 @@ ;; The posn struct for the teaching languages (provide struct:posn make-posn posn? posn-x posn-y set-posn-x! set-posn-y! + (rename-out (posn posn-id)) (rename-out (posn-signature posn))) (struct posn (x y) #:mutable #:transparent) diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 9d5eee2e2a..81a569823e 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -49,7 +49,10 @@ (rename deinprogramm/quickcheck/quickcheck quickcheck:property property) test-engine/scheme-tests scheme/class - (only lang/private/teachprims beginner-equal? beginner-equal~?)) + "../posn.rkt" + (only lang/private/teachprims + beginner-equal? beginner-equal~? + advanced-cons advanced-list*)) (require-for-syntax "teachhelp.ss" "teach-shared.ss" syntax/kerncase @@ -209,6 +212,7 @@ advanced-begin advanced-begin0 advanced-case + advanced-match advanced-shared advanced-delay) @@ -2520,6 +2524,133 @@ (with-syntax ([clauses clauses]) (syntax/loc stx (case v-expr . clauses)))))] [_else (bad-use-error 'case stx)])))) + + ;; match (advanced) + (define (advanced-match/proc stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_) + (teach-syntax-error + 'match + stx + #f + "expected an expression after `match', but nothing's there")] + [(_ expr) + (teach-syntax-error + 'match + stx + #f + "expected a pattern--answer clause after the expression following `match', but nothing's there")] + [(_ v-expr clause ...) + (let ([clauses (syntax->list (syntax (clause ...)))]) + (for-each + (lambda (clause) + (syntax-case clause () + [(pattern answer ...) + (let ([pattern (syntax pattern)] + [answers (syntax->list (syntax (answer ...)))]) + (check-single-expression 'match + "for the answer in a `match' clause" + clause + answers + null))] + [() + (teach-syntax-error + 'match + stx + clause + "expected a pattern--answer clause, but found an empty clause")] + [_else + (teach-syntax-error + 'match + stx + clause + "expected a pattern--answer clause, but found ~a" + (something-else clause))])) + clauses) + + (letrec + ([check-and-translate-qqp + (λ (qqp) + (syntax-case qqp (intermediate-unquote intermediate-unquote-splicing) + [(intermediate-unquote p) + (quasisyntax/loc qqp + (unquote #,(check-and-translate-p #'p)))] + [(intermediate-unquote-splicing p) + (quasisyntax/loc qqp + (unquote-splicing #,(check-and-translate-p #'p)))] + [(qqpi ...) + (quasisyntax/loc qqp + (#,@(map check-and-translate-qqp (syntax->list #'(qqpi ...)))))] + [_ + qqp]))] + [check-and-translate-p + (λ (p) + (syntax-case p (struct posn true false empty intermediate-quote intermediate-quasiquote advanced-cons list advanced-list* vector box) + [true + (syntax/loc p + #t)] + [false + (syntax/loc p + #f)] + [empty + (syntax/loc p + (list))] + [(intermediate-quote qp) + (syntax/loc p + (quote qp))] + [(intermediate-quasiquote qqp) + (quasisyntax/loc p + (quasiquote #,(check-and-translate-qqp #'qqp)))] + [(advanced-cons p1 p2) + (quasisyntax/loc p + (cons #,(check-and-translate-p #'p1) + #,(check-and-translate-p #'p2)))] + [(list pi ...) + (quasisyntax/loc p + (list #,@(map check-and-translate-p (syntax->list #'(pi ...)))))] + [(advanced-list* pi ...) + (quasisyntax/loc p + (list* #,@(map check-and-translate-p (syntax->list #'(pi ...)))))] + [(struct posn (pi ...)) + (quasisyntax/loc p + (struct posn-id #,(map check-and-translate-p (syntax->list #'(pi ...)))))] + [(struct struct-id (pi ...)) + (quasisyntax/loc p + (struct struct-id #,(map check-and-translate-p (syntax->list #'(pi ...)))))] + [(vector pi ...) + (quasisyntax/loc p + (vector #,@(map check-and-translate-p (syntax->list #'(pi ...)))))] + [(box p1) + (quasisyntax/loc p + (box #,(check-and-translate-p #'p1)))] + [_ + (let ([v (syntax->datum p)]) + (if (or (and (symbol? v) + (not (member v '(true false empty)))) + (number? v) + (string? v) + (char? v)) + p + (teach-syntax-error + 'match + stx + p + "expected a pattern, but found ~a" + (something-else p))))]))]) + (let ([clauses + (map (λ (c) + (syntax-case c () + [(p e) + (quasisyntax/loc c + (#,(check-and-translate-p #'p) e))])) + clauses)]) + (with-syntax ([clauses clauses]) + (syntax/loc stx + (match v-expr . clauses))))))] + [_else (bad-use-error 'match stx)])))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; delay (advanced) diff --git a/collects/scribblings/htdp-langs/advanced.scrbl b/collects/scribblings/htdp-langs/advanced.scrbl index b6a22f1d93..8132ac420f 100644 --- a/collects/scribblings/htdp-langs/advanced.scrbl +++ b/collects/scribblings/htdp-langs/advanced.scrbl @@ -43,7 +43,9 @@ @schemegrammar*+qq[ #:literals (define define-struct define-datatype lambda λ cond else if and or empty true false require lib planet - local let let* letrec time begin begin0 set! delay shared recur when case unless + local let let* letrec time begin begin0 set! delay shared recur when case match unless + ; match + _ cons list list* struct vector box check-expect check-within check-error) (check-expect check-within check-error require) [program (code:line def-or-expr ...)] @@ -75,6 +77,7 @@ [(choice choice ...) expr]) (case expr [(choice choice ...) expr] ... [else expr]) + (match expr [pattern expr] ...) (if expr expr expr) (when expr expr) (unless expr expr) @@ -88,11 +91,37 @@ (code:line @#,elem{@schemevalfont{`}@scheme[_quasiquoted]} (code:comment @#,seclink["beginner-abbr-quasiquote"]{quasiquote})) number true + false string character] [choice (code:line id (code:comment @#,t{treated as a symbol})) number] +[pattern _ + empty + id + number + true + false + string + character + @#,elem{@schemevalfont{'}@scheme[_quoted]} + @#,elem{@schemevalfont{`}@scheme[_quasiquoted-pattern]} + (cons pattern pattern) + (list pattern ...) + (list* pattern ...) + (struct id (pattern ...)) + (vector pattern ...) + (box pattern)] +[quasiquoted-pattern id + number + string + character + (quasiquoted-pattern ...) + @#,elem{@schemevalfont{'}@scheme[_quasiquoted-pattern]} + @#,elem{@schemevalfont{`}@scheme[_quasiquoted-pattern]} + @#,elem{@schemefont[","]@scheme[_pattern]} + @#,elem{@schemefont[",@"]@scheme[_pattern]}] ] @|prim-nonterms| @@ -293,7 +322,22 @@ This form of @scheme[case] is similar to the prior one, except that the final @scheme[else] clause is always taken if no prior line contains a choice matching the value of the initial @scheme[expr]. In other words, so there is no possibility to ``fall off the end'' of -the @scheme[case] form.} +the @scheme[case] form.}@; ---------------------------------------------------------------------- + +@section{@scheme[match]} + +@defform[(match expr [pattern expr] ...)]{ + +A @scheme[match] form contains one or more ``lines'' that are +surrounded by parentheses or square brackets. Each line contains a +pattern---a description of a value---and an answer @scheme[expr]. +The initial @scheme[expr] is evaluated, and the resulting value +is matched against the pattern in each line, where the lines are +considered in order. The first line that contains a matching pattern +provides an answer @scheme[expr] whose value is the result of the +whole @scheme[match] expression. This @scheme[expr] may reference +identifiers bound in the matching pattern. If none of the lines +contains a matching pattern, it is an error.} @; ---------------------------------------------------------------------- diff --git a/collects/tests/racket/advanced.rktl b/collects/tests/racket/advanced.rktl index 67728d8cdf..822ef1ed2d 100644 --- a/collects/tests/racket/advanced.rktl +++ b/collects/tests/racket/advanced.rktl @@ -343,6 +343,102 @@ (htdp-test #f 'a? (a? 1)) (htdp-top-pop 1) +;; match + +(htdp-syntax-test #'match #rx"match: found a use of `match' that does not follow an open parenthesis") +(htdp-syntax-test #'(match) #rx"match: expected an expression after `match', but nothing's there") +(htdp-syntax-test #'(match 1) #rx"match: expected a pattern--answer clause after the expression following `match', but nothing's there") + +(htdp-syntax-test #'(match 1 10) #rx"match: expected a pattern--answer clause, but found a number") +(htdp-syntax-test #'(match 1 x) #rx"match: expected a pattern--answer clause, but found something else") +(htdp-syntax-test #'(match 1 []) #rx"match: expected a pattern--answer clause, but found an empty clause") +(htdp-syntax-test #'(match 1 [x]) #rx"expected an expression for the answer in a `match' clause, but nothing's there") +(htdp-syntax-test #'(match 1 [x 10 10]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part") +(htdp-syntax-test #'(match 1 [x 10 x]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part") + +(htdp-syntax-test #'(match 1 [x 10] 10) #rx"match: expected a pattern--answer clause, but found a number") +(htdp-syntax-test #'(match 1 [x 10] x) #rx"match: expected a pattern--answer clause, but found something else") +(htdp-syntax-test #'(match 1 [x 10] []) #rx"match: expected a pattern--answer clause, but found an empty clause") +(htdp-syntax-test #'(match 1 [x 10] [x]) #rx"expected an expression for the answer in a `match' clause, but nothing's there") +(htdp-syntax-test #'(match 1 [x 10] [x 10 10]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part") +(htdp-syntax-test #'(match 1 [x 10] [x 10 x]) #rx"expected only one expression for the answer in a `match' clause, but found one extra part") + +(define-syntax-rule (htdp-match/v res pat expr val) + (htdp-test res 'pat (match expr [pat val] [else #f]))) +(define-syntax-rule (htdp-match res pat expr) + (htdp-match/v res pat expr #t)) + +(htdp-match #t true true) +(htdp-match #f true false) +(htdp-match #f true 1) + +(htdp-match #f false true) +(htdp-match #t false false) +(htdp-match #f false 1) + +(htdp-match #t empty empty) +(htdp-match #f empty 1) + +(htdp-match #t 1 1) +(htdp-match #t '1 1) +(htdp-match #t `1 1) +(htdp-match #f 1 2) + +(htdp-match #t "foo" "foo") +(htdp-match #t '"foo" "foo") +(htdp-match #t `"foo" "foo") +(htdp-match #f "foo" "bar") + +(htdp-match #t #\a #\a) +(htdp-match #t '#\a #\a) +(htdp-match #t `#\a #\a) +(htdp-match #f #\a #\b) + +(htdp-match #t 'a 'a) +(htdp-match #f 'a 'b) + +(htdp-match #t '(a b) (list 'a 'b)) +(htdp-match #t ''a ''a) +(htdp-match #t '`a '`a) +(htdp-match #t ',a ',a) +(htdp-match #t ',@a ',@a) + +(htdp-match #t `(a b) (list 'a 'b)) +(htdp-match #t `'a ''a) +(htdp-match #t ``a '`a) + +(htdp-match #t (cons a b) (list 1)) +(htdp-match #f (cons 1 2) 1) +(htdp-match #t (list a b) (list 1 2)) +(htdp-match #f (list a b) (list 1)) +(htdp-match #t (list* a b) (list 1)) +(htdp-match #f (list* a b) empty) + +(htdp-match #t (vector x y) (vector 1 2)) +(htdp-match #f (vector x x) (vector 1 2)) +(htdp-match #t (vector _ _) (vector 1 2)) +(htdp-match #f (vector x y) (vector 1)) + +(htdp-match #t (box x) (box 1)) +(htdp-match #f (box x) 1) + +(htdp-match/v 1 a 1 a) + +(htdp-top (define-struct my-posn (x y))) +(htdp-match/v 3 (struct my-posn (x y)) (make-my-posn 1 2) (+ x y)) +(htdp-top-pop 1) + +(htdp-match/v 3 (struct posn (x y)) (make-posn 1 2) (+ x y)) +(htdp-match/v 3 (cons (struct posn (x y)) empty) (cons (make-posn 1 2) empty) (+ x y)) +(htdp-match/v 3 (list* (struct posn (x y)) empty) (list* (make-posn 1 2) empty) (+ x y)) +(htdp-match/v 3 (list (struct posn (x y))) (list (make-posn 1 2)) (+ x y)) +(htdp-match/v 3 (vector (struct posn (x y))) (vector (make-posn 1 2)) (+ x y)) +(htdp-match/v 3 (box (struct posn (x y))) (box (make-posn 1 2)) (+ x y)) + +(htdp-match/v 3 `,(struct posn (x y)) (make-posn 1 2) (+ x y)) +(htdp-match/v 1 `(a ,b) (list 'a 1) b) +(htdp-match/v 1 `(a ,@(list b)) (list 'a 1) b) + ;; ---------------------------------------- (report-errs) diff --git a/collects/tests/racket/beg-adv.rktl b/collects/tests/racket/beg-adv.rktl index 6f9579568d..00b5247932 100644 --- a/collects/tests/racket/beg-adv.rktl +++ b/collects/tests/racket/beg-adv.rktl @@ -397,10 +397,3 @@ (htdp-err/rt-test (error "several numbers " 1 " 2 " 3 " 4") #rx"^several numbers 1 2 3 4$") -(htdp-top (require scheme/match)) -(htdp-test 17 'match (match 'x ['x 17])) -(htdp-test 'x 'match (match 'x ['y 17][z z])) -(htdp-test 2 'match (match (list 1 2 3) [(cons a (cons b c)) b])) -(htdp-test 3 'match (match (list 1 2 3) [(list a b c) c])) -(htdp-test (list 2 3) 'match (match (list 1 2 3) [(cons a c) c])) -(htdp-top-pop 1) diff --git a/collects/tests/racket/bega-adv.rktl b/collects/tests/racket/bega-adv.rktl index 1a484afb7c..52c59596ba 100644 --- a/collects/tests/racket/bega-adv.rktl +++ b/collects/tests/racket/bega-adv.rktl @@ -30,13 +30,3 @@ (htdp-syntax-test #'((unquote-splicing (list 10)))) (htdp-err/rt-test `(,@4)) - -(htdp-top (require scheme/match)) -(htdp-test 17 'match (match 'x [`x 17])) -(htdp-test 'x 'match (match 'x [`y 17][z z])) -(htdp-test 2 'match (match (list 1 2 3) [`(,a ,b 3) b])) -(htdp-test 'no 'match (match (list 1 2 3) [`(,a ,b 4) b] [z 'no])) -(htdp-test 2 'match (match (list 1 2 3) [`(,a ,b ,c) b])) -(htdp-test 2 'match (match (list 1 2 3) [`(,a ,@`(,b ,@`(,c))) b])) -(htdp-test (list 2 3) 'match (match (list 1 2 3) [`(,a ,b ...) b])) -(htdp-top-pop 1)