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

Use new match-a-pattern macro where appropriate

Browse Source
This commit is contained in:
Max New 2013-10-16 15:28:18 -05:00
parent fca30c03e8
commit 63c05d6cf5
2 changed files with 30 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
pkgs/redex-pkgs/redex-lib/redex/private/preprocess-lang.rkt
View File

@ -57,10 +57,9 @@
(λ (rhs)
(let loop ([pat (rhs-pattern rhs)]
[s (set)])
(match
(match-a-pattern/single-base-case
pat
[`(nt ,id)
(set-add s id)]
[`(name ,name ,pat)
(loop pat s)]
[`(mismatch-name ,name ,pat)
@ -69,6 +68,7 @@
(set-union (loop p1 s)
(loop p2 s))]
[`(hide-hole ,p) (loop p s)]
[`(side-condition ,p ,_ ,_) (loop p s)]
[`(list ,sub-pats ...)
(fold-map/set
(λ (sub-pat)
@ -77,7 +77,11 @@
(loop pat s)]
[else (loop sub-pat s)]))
sub-pats)]
[else s])))
[_ (match pat
[`(nt ,id)
(set-add s id)]
[_ s])
])))
(nt-rhs nt))))
(hash)
lang))
@ -217,16 +221,19 @@
;; directly-used-nts : pat -> (setof symbol)
(define (directly-used-nts pat)
(match pat
[`(nt ,id) (set id)]
[(or `(name ,n ,p)
`(mismatch-name ,n ,p))
(match-a-pattern/single-base-case pat
[`(name ,n ,p)
(directly-used-nts p)]
[`(mismatch-name ,n ,p)
(directly-used-nts p)]
[`(in-hole ,p1 ,p2)
(set-union (directly-used-nts p1)
(directly-used-nts p2))]
[`(hide-hole ,p)
(directly-used-nts p)]
[`(side-condition ,p ,c ,v)
(directly-used-nts p)]
[`(list ,sub-pats ...)
(fold-map/set
(λ (sub-pat)
@ -236,7 +243,9 @@
[`(repeat ,p ,n ,m) (set)]
[else (directly-used-nts sub-pat)]))
sub-pats)]
[else (set)]))
[_ (match pat
[`(nt ,id) (set id)]
[_ (set)])]))
;; used-vars : lang -> (listof symbol)
(define (used-vars lang)

18
pkgs/redex-pkgs/redex-lib/redex/private/preprocess-pat.rkt
View File

@ -43,7 +43,7 @@
(and (not (set-member? badnames name))
name))
(define (strip pat)
(match pat
(match-a-pattern/single-base-case pat
[`(name ,n ,subpat)
(strip-named n subpat (λ (n s) `(name ,n ,s)))]
[`(mismatch-name ,n ,subpat)
@ -53,6 +53,8 @@
,(strip p2))]
[`(hide-hole ,p)
`(hide-hole ,(strip p))]
[`(side-condition ,p ,c ,s)
`(side-condition ,(strip p) ,c ,s)]
[`(list ,sub-pats ...)
(cons 'list
(map (match-lambda
@ -63,13 +65,15 @@
`(repeat ,sub ,s-n ,s-m)]
[sub-pat (strip sub-pat)])
sub-pats))]
[else pat]))
[_ pat]))
(strip pat))
(define (find-names pat)
(match pat
[(or `(name ,n ,subpat)
`(mismatch ,n ,subpat))
(match-a-pattern/single-base-case pat
[`(name ,n ,subpat)
(2set-add (find-names subpat)
n)]
[`(mismatch-name ,n ,subpat)
(2set-add (find-names subpat)
n)]
[`(in-hole ,p1 ,p2)
@ -77,6 +81,8 @@
(find-names p2))]
[`(hide-hole ,p)
(find-names p)]
[`(side-condition ,p ,c ,s)
(find-names p)]
[`(list ,sub-pats ...)
(foldr 2set-union
2set-empty
@ -85,4 +91,4 @@
(2set-add (find-names p) n m)]
[sub-pat (find-names sub-pat)])
sub-pats))]
[else 2set-empty]))
[_ 2set-empty]))