mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

elide works like seq (better) ; tests pass

Browse Source
dev-elider
Matthew Butterick 9 years ago
parent 9babe76e3c
commit 7bf8a29bd3
1 changed files with 15 additions and 17 deletions
Show Stats Download Patch File Download Diff File

32
beautiful-racket-ragg/br/ragg/codegen/flatten.rkt
Unescape Escape View File

@ -72,7 +72,7 @@
[origin (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])]) [origin (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])])
(syntax-case a-rule (rule) (syntax-case a-rule (rule)
[(rule name pat) [(rule name pat)
(syntax-case #'pat (id inferred-id lit token choice elide repeat maybe seq) (syntax-case #'pat (id inferred-id lit token choice repeat maybe seq elide)
;; The primitive types stay as they are: ;; The primitive types stay as they are:
[(id val) [(id val)
@ -98,18 +98,6 @@
(append (list #'(head origin name [sub-pat ...] ...)) (append (list #'(head origin name [sub-pat ...] ...))
(apply append (reverse inferred-ruless/rev)))))] (apply append (reverse inferred-ruless/rev)))))]
[(elide sub-pat ...)
(begin
(define-values (inferred-ruless/rev new-sub-patss/rev)
(for/fold ([rs '()] [ps '()])
([p (syntax->list #'(sub-pat ...))])
(let-values ([(new-r new-p)
(lift-nonprimitive-pattern p)])
(values (cons new-r rs) (cons new-p ps)))))
(with-syntax ([((sub-pat ...) ...) (reverse new-sub-patss/rev)])
(append (list #'(head origin name [sub-pat ...] ...))
(apply append (reverse inferred-ruless/rev)))))]
[(repeat min sub-pat) [(repeat min sub-pat)
(begin (begin
(define-values (inferred-rules new-sub-pats) (define-values (inferred-rules new-sub-pats)
@ -136,6 +124,14 @@
inferred-rules)))] inferred-rules)))]
[(seq sub-pat ...) [(seq sub-pat ...)
(begin
(define-values (inferred-rules new-sub-pats)
(lift-nonprimitive-patterns (syntax->list #'(sub-pat ...))))
(with-syntax ([(sub-pat ...) new-sub-pats])
(cons #'(head origin name [sub-pat ...])
inferred-rules)))]
[(elide sub-pat ...)
(begin (begin
(define-values (inferred-rules new-sub-pats) (define-values (inferred-rules new-sub-pats)
(lift-nonprimitive-patterns (syntax->list #'(sub-pat ...)))) (lift-nonprimitive-patterns (syntax->list #'(sub-pat ...))))
@ -151,7 +147,7 @@
;; Returns true if the pattern looks primitive ;; Returns true if the pattern looks primitive
(define (primitive-pattern? a-pat) (define (primitive-pattern? a-pat)
(syntax-case a-pat (id lit token choice elide repeat maybe seq) (syntax-case a-pat (id lit token choice elide repeat maybe seq elide)
[(id val) [(id val)
#t] #t]
[(lit val) [(lit val)
@ -160,13 +156,13 @@
#t] #t]
[(choice sub-pat ...) [(choice sub-pat ...)
#f] #f]
[(elide sub-pat)
#f]
[(repeat min val) [(repeat min val)
#f] #f]
[(maybe sub-pat) [(maybe sub-pat)
#f] #f]
[(seq sub-pat ...) [(seq sub-pat ...)
(andmap primitive-pattern? (syntax->list #'(sub-pat ...)))]
[(elide sub-pat ...)
(andmap primitive-pattern? (syntax->list #'(sub-pat ...)))])) (andmap primitive-pattern? (syntax->list #'(sub-pat ...)))]))
@ -175,7 +171,7 @@
;; and tokens. ;; and tokens.
(define (linearize-primitive-pattern a-pat) (define (linearize-primitive-pattern a-pat)
(define (traverse a-pat acc) (define (traverse a-pat acc)
(syntax-case a-pat (id inferred-id lit token seq) (syntax-case a-pat (id inferred-id lit token seq elide)
[(id val) [(id val)
(cons a-pat acc)] (cons a-pat acc)]
[(inferred-id val reason) [(inferred-id val reason)
@ -185,6 +181,8 @@
[(token val) [(token val)
(cons a-pat acc)] (cons a-pat acc)]
[(seq vals ...) [(seq vals ...)
(foldl traverse acc (syntax->list #'(vals ...)))]
[(elide vals ...)
(foldl traverse acc (syntax->list #'(vals ...)))])) (foldl traverse acc (syntax->list #'(vals ...)))]))
(reverse (traverse a-pat '()))) (reverse (traverse a-pat '())))

Write Preview
Loading…
Cancel
Save