Adding match to ASL

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]
             )

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)

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)

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.}
 
 @; ----------------------------------------------------------------------
 

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)

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)

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)