[racket-dev] [plt] Push #20751: master branch updated
This commit finishes adding 'define-datatype' and 'match' to ASL per
Shriram's request.
I'd like comments and improvements on a few things:
1) The documentation -- most of the ASL docs are very vague,
presumably because the book covers it, but in this case that's not
true
2) The subset of match supported
3) The way I've prevented escaping to the larger part of ASL.
Jay
On Thu, Jul 22, 2010 at 3:40 PM, <jay at racket-lang.org> wrote:
> jay has updated `master' from 9eb053d4db to 407dcee206.
> http://git.racket-lang.org/plt/9eb053d4db..407dcee206
>
> =====[ 2 Commits ]======================================================
>
> Directory summary:
> 45.5% collects/lang/private/
> 15.2% collects/scribblings/htdp-langs/
> 38.1% collects/tests/racket/
>
> ~~~~~~~~~~
>
> eeada45 Jay McCarthy <jay at racket-lang.org> 2010-07-22 15:12
> :
> | Fixing error string
> :
> M collects/lang/private/teachprims.rkt | 2 +-
>
> ~~~~~~~~~~
>
> 407dcee Jay McCarthy <jay at racket-lang.org> 2010-07-22 15:39
> :
> | Adding match to ASL
> :
> M collects/lang/htdp-advanced.rkt | 1 +
> M collects/lang/posn.rkt | 1 +
> M collects/lang/private/teach.rkt | 133 ++++++++++++++++++++-
> M collects/scribblings/htdp-langs/advanced.scrbl | 48 +++++++-
> M collects/tests/racket/advanced.rktl | 96 +++++++++++++++
> M collects/tests/racket/bega-adv.rktl | 10 --
> M collects/tests/racket/beg-adv.rktl | 7 -
>
> =====[ Overall Diff ]===================================================
>
> collects/lang/htdp-advanced.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/htdp-advanced.rkt
> +++ NEW/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
> ~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/posn.rkt
> +++ NEW/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
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/private/teach.rkt
> +++ NEW/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/lang/private/teachprims.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/private/teachprims.rkt
> +++ NEW/collects/lang/private/teachprims.rkt
> @@ -504,7 +504,7 @@ namespace.
>
> (define-teach beginner string-whitespace?
> (lambda (s)
> - (cerr 'string-upper-case? (string? s) "<string>" s)
> + (cerr 'string-whitespace? (string? s) "<string>" s)
> (andmap char-whitespace? (string->list s))))
>
> ;; -----------------------------------------------------------------------------
>
> collects/scribblings/htdp-langs/advanced.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/scribblings/htdp-langs/advanced.scrbl
> +++ NEW/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.}@; ----------------------------------------------------------------------
> +
> + at section{@scheme[match]}
> +
> + at 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
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/racket/advanced.rktl
> +++ NEW/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 ', at a ', at 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
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/racket/beg-adv.rktl
> +++ NEW/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
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/racket/bega-adv.rktl
> +++ NEW/collects/tests/racket/bega-adv.rktl
> @@ -30,13 +30,3 @@
> (htdp-syntax-test #'((unquote-splicing (list 10))))
>
> (htdp-err/rt-test `(, at 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)
>
--
Jay McCarthy <jay at cs.byu.edu>
Assistant Professor / Brigham Young University
http://teammccarthy.org/jay
"The glory of God is Intelligence" - D&C 93
![[logo]](/logo.png){kind=logo}