From 68a2257f2ad87a8925a1158c6a9c63514dbd630e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Jul 2009 16:11:12 +0000 Subject: [PATCH] better interaction of HtDP languages with scheme/match svn: r15462 --- collects/lang/private/teach.ss | 81 +++++++++++++++++++++++++---- collects/tests/mzscheme/beg-adv.ss | 7 +++ collects/tests/mzscheme/bega-adv.ss | 10 ++++ 3 files changed, 89 insertions(+), 9 deletions(-) diff --git a/collects/lang/private/teach.ss b/collects/lang/private/teach.ss index 5330e7b815..38d29cddf4 100644 --- a/collects/lang/private/teach.ss +++ b/collects/lang/private/teach.ss @@ -37,6 +37,7 @@ (require mzlib/etc mzlib/list mzlib/math + scheme/match "set-result.ss") (require-for-syntax "teachhelp.ss" "teach-shared.ss" @@ -137,7 +138,7 @@ beginner-if beginner-and beginner-or - beginner-quote + beginner-quote/expr beginner-require beginner-dots @@ -150,8 +151,8 @@ intermediate-let* intermediate-recur intermediate-app - intermediate-quote - intermediate-quasiquote + intermediate-quote/expr + intermediate-quasiquote/expr intermediate-unquote intermediate-unquote-splicing intermediate-time @@ -1131,7 +1132,7 @@ ;; quote (symbols) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define (beginner-quote/proc stx) + (define (beginner-quote/expr/proc stx) (syntax-case stx () [(_ expr) (let ([sym (syntax expr)]) @@ -1758,7 +1759,7 @@ ;; quote (intermediate) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define intermediate-quote/proc + (define intermediate-quote/expr/proc (lambda (stx) (syntax-case stx () [(_ expr ...) @@ -1780,7 +1781,7 @@ ;; suitable error messages. The "right" cons is actually advanced-cons, ;; because it works with shared: - (define (intermediate-quasiquote/proc stx) + (define (intermediate-quasiquote/expr/proc stx) (let loop ([stx (syntax-case stx () [(_ stx) (syntax stx)] [(_ . any) @@ -1811,7 +1812,7 @@ (with-syntax ([x (loop (syntax x) (sub1 depth))] [rest (loop (syntax rest) depth)] [uq-splicing (stx-car (stx-car stx))]) - (stepper-syntax-property (syntax/loc stx (the-cons (list (quote uq-splicing) x) rest)) + (stepper-syntax-property (syntax/loc stx (the-cons/matchable (list (quote uq-splicing) x) rest)) 'stepper-hint 'quasiquote-the-cons-application)))] [intermediate-unquote-splicing @@ -1827,7 +1828,7 @@ [(a . b) (with-syntax ([a (loop (syntax a) depth)] [b (loop (syntax b) depth)]) - (stepper-syntax-property (syntax/loc stx (the-cons a b)) + (stepper-syntax-property (syntax/loc stx (the-cons/matchable a b)) 'stepper-hint 'quasiquote-the-cons-application))] [any @@ -2383,4 +2384,66 @@ [_else (bad-use-error 'shared stx)]) ;; The main implementation - (shared/proc stx make-check-cdr #'undefined))))))) + (shared/proc stx make-check-cdr #'undefined)))))) + + ;; ---------------------------------------- + ;; Extend quote forms to work with `match': + + (provide beginner-quote + intermediate-quote + intermediate-quasiquote) + + (define-match-expander beginner-quote + (syntax-local-value #'beginner-quote/expr) + (syntax-local-value #'beginner-quote/expr)) + + (define-match-expander intermediate-quote + (syntax-local-value #'intermediate-quote/expr) + (syntax-local-value #'intermediate-quote/expr)) + + (define-match-expander intermediate-quasiquote + ;; Match expander: + (let ([qq (syntax-local-value #'intermediate-quasiquote/expr)]) + (lambda (stx) + ;; Call expression version for checking: + (qq stx) + ;; But then just use `scheme/base' quasiquote and unquotes: + (quasisyntax/loc stx + (quasiquote + #,(let loop ([stx (syntax-case stx () + [(_ stx) (syntax stx)])] + [depth 0]) + (syntax-case stx (intermediate-unquote intermediate-unquote-splicing intermediate-quasiquote) + [(intermediate-unquote x) + (if (zero? depth) + (syntax (unquote x)) + (with-syntax ([x (loop (syntax x) (sub1 depth))]) + (syntax/loc stx (unquote x))))] + [((intermediate-unquote-splicing x) . rest) + (if (zero? depth) + (with-syntax ([rest (loop (syntax rest) depth)]) + (syntax/loc stx ((unquote-splicing x) . rest))) + (with-syntax ([x (loop (syntax x) (sub1 depth))] + [rest (loop (syntax rest) depth)]) + (syntax/loc stx ((unquote-splicing x) . rest))))] + [(intermediate-quasiquote x) + (with-syntax ([x (loop (syntax x) (add1 depth))] + [qq (stx-car stx)]) + (syntax/loc stx (quasiquote x)))] + [(a . b) + (with-syntax ([a (loop (syntax a) depth)] + [b (loop (syntax b) depth)]) + (syntax/loc stx (a . b)))] + [any stx])))))) + ;; Expression expander: + (syntax-local-value #'intermediate-quasiquote/expr)) + + (define-match-expander the-cons/matchable + ;; For match (no cdr check needed for deconstruction): + (lambda (stx) + (syntax-case stx () + [(_ a b) (syntax/loc stx (cons a b))])) + ;; For expressions (cdr check via `the-cons'): + (lambda (stx) + (syntax-case stx () + [(_ a b) (syntax/loc stx (the-cons a b))])))) diff --git a/collects/tests/mzscheme/beg-adv.ss b/collects/tests/mzscheme/beg-adv.ss index 72942ea8c4..7789e80e39 100644 --- a/collects/tests/mzscheme/beg-adv.ss +++ b/collects/tests/mzscheme/beg-adv.ss @@ -387,3 +387,10 @@ (htdp-test false 'string-lower-case? (string-lower-case? "ab\t")) (htdp-test true 'string-lower-case? (string-lower-case? "abc")) +(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/mzscheme/bega-adv.ss b/collects/tests/mzscheme/bega-adv.ss index 52c59596ba..1a484afb7c 100644 --- a/collects/tests/mzscheme/bega-adv.ss +++ b/collects/tests/mzscheme/bega-adv.ss @@ -30,3 +30,13 @@ (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)