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

29
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,15 +97,19 @@ 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))
(unless (and (non-recursive? i) skip-non-recursive?)
(define pats-match? (define pats-match?
(let loop ([pat (syntax->datum pat)] (let loop ([pat (syntax->datum pat)]
[should-be should-be]) [should-be should-be])
@ -119,22 +124,26 @@ turns into this:
(loop (cdr pat) (cdr should-be)))])] (loop (cdr pat) (cdr should-be)))])]
[else (equal? pat should-be)]))) [else (equal? pat should-be)])))
(unless pats-match? (unless pats-match?
(raise-syntax-error 'match-a-pattern (raise-syntax-error #f
(format "expected pattern ~s" (format "expected pattern ~s"
should-be) should-be)
stx stx
pat))) 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))