suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

a start on a variant of match-a-pattern

Browse Source 
that allows you to avoid enumerating the
non-recursive pattterns (and use an else clause)
This commit is contained in:
Robby Findler 2013-10-14 18:36:57 -05:00
parent 1bb4eb8879
commit 66683cdffe
1 changed files with 36 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
pkgs/redex-pkgs/redex-lib/redex/private/match-a-pattern.rkt
View File

@ -2,7 +2,7 @@
(require racket/match (require racket/match
(for-syntax racket/match (for-syntax racket/match
racket/base)) racket/base))
(provide match-a-pattern) (provide match-a-pattern match-a-pattern/single-base-case)
#| #|
@ -72,9 +72,10 @@ turns into this:
|# |#
(define-syntax (match-a-pattern stx) (define-for-syntax (match-a-pattern/proc stx skip-non-recursive?)
(define (check-pats pats allow-else?) (define (check-pats pats allow-else?)
(let () (let ()
(define (non-recursive? x) (or (<= x 12) (= x 20)))
(define should-be-pats (define should-be-pats
(append '(`any (append '(`any
`number `number
@ -96,45 +97,53 @@ turns into this:
`(side-condition ,pat ,condition ,srcloc-expr) `(side-condition ,pat ,condition ,srcloc-expr)
`(cross ,var) `(cross ,var)
`(list ,lpat ...) `(list ,lpat ...)
(? (compose not pair?))) ;; pattern for literals (numbers, strings, prefabs, etc etc etc)
(if allow-else? ;; pattern for literals (numbers, strings, prefabs, etc etc etc)
(? (compose not pair?)))
(if (or allow-else? skip-non-recursive?)
(list '_) (list '_)
(list)))) (list))))
(for ([pat (in-list pats)]) (for ([pat (in-list pats)]
[i (in-naturals)])
(when (null? should-be-pats) (when (null? should-be-pats)
(raise-syntax-error 'match-a-pattern "too many patterns" stx pat)) (raise-syntax-error #f "too many patterns" stx pat))
(define should-be (car should-be-pats)) (define should-be (car should-be-pats))
(set! should-be-pats (cdr should-be-pats)) (set! should-be-pats (cdr should-be-pats))
(define pats-match? (unless (and (non-recursive? i) skip-non-recursive?)
(let loop ([pat (syntax->datum pat)] (define pats-match?
[should-be should-be]) (let loop ([pat (syntax->datum pat)]
(cond [should-be should-be])
[(and (null? pat) (null? should-be)) #t] (cond
[(and (pair? pat) (pair? should-be)) [(and (null? pat) (null? should-be)) #t]
(cond [(and (pair? pat) (pair? should-be))
[(eq? (car should-be) 'unquote) (cond
(eq? (car pat) 'unquote)] [(eq? (car should-be) 'unquote)
[else (eq? (car pat) 'unquote)]
(and (loop (car pat) (car should-be)) [else
(loop (cdr pat) (cdr should-be)))])] (and (loop (car pat) (car should-be))
[else (equal? pat should-be)]))) (loop (cdr pat) (cdr should-be)))])]
(unless pats-match? [else (equal? pat should-be)])))
(raise-syntax-error 'match-a-pattern (unless pats-match?
(format "expected pattern ~s" (raise-syntax-error #f
should-be) (format "expected pattern ~s"
stx should-be)
pat))) stx
pat))))
(unless (null? should-be-pats) (unless (null? should-be-pats)
(raise-syntax-error 'match-a-pattern (raise-syntax-error #f
(format "did not find pattern ~s" (format "did not find pattern ~s"
(car should-be-pats)) (car should-be-pats))
stx)))) stx))))
(syntax-case stx () (syntax-case stx ()
[(_ #:allow-else to-match [pats rhs ...] ...) [(_ #:allow-else to-match [pats rhs ...] ...)
(not skip-non-recursive?)
(let () (let ()
(check-pats (syntax->list #'(pats ...)) #t) (check-pats (syntax->list #'(pats ...)) #t)
#'(match to-match [pats rhs ...] ...))] #'(match to-match [pats rhs ...] ...))]
[(_ to-match [pats rhs ...] ...) [(_ to-match [pats rhs ...] ...)
(let () (let ()
(check-pats (syntax->list #'(pats ...)) #f) (check-pats (syntax->list #'(pats ...)) skip-non-recursive?)
#'(match to-match [pats rhs ...] ...))])) #'(match to-match [pats rhs ...] ...))]))
(define-syntax (match-a-pattern stx) (match-a-pattern/proc stx #f))
(define-syntax (match-a-pattern/single-base-case stx) (match-a-pattern/proc stx #f))