Name unnamed repeats in Redex.
This commit is contained in:
Max New
parent
3becf8492b
commit
22a1a185df
|
|
@ -3,7 +3,6 @@
|
||||||
racket/list
|
racket/list
|
||||||
racket/match
|
racket/match
|
||||||
racket/function
|
racket/function
|
||||||
racket/set
|
|
||||||
"lang-struct.rkt"
|
"lang-struct.rkt"
|
||||||
"match-a-pattern.rkt"
|
"match-a-pattern.rkt"
|
||||||
"enumerator.rkt"
|
"enumerator.rkt"
|
||||||
|
|
@ -46,7 +45,10 @@
|
||||||
(enum-f (nt-rhs nt)
|
(enum-f (nt-rhs nt)
|
||||||
l-enums))))
|
l-enums))))
|
||||||
cur-lang))
|
cur-lang))
|
||||||
(let-values ([(fin-lang rec-lang) (sep-lang lang)])
|
(let-values ([(fin-lang rec-lang)
|
||||||
|
(sep-lang
|
||||||
|
(map ((curry map-nt-rhs-pat) name-all-repeats)
|
||||||
|
lang))])
|
||||||
(enumerate-lang fin-lang
|
(enumerate-lang fin-lang
|
||||||
enumerate-rhss)
|
enumerate-rhss)
|
||||||
(enumerate-lang rec-lang
|
(enumerate-lang rec-lang
|
||||||
|
|
@ -73,207 +75,86 @@
|
||||||
l-enums))
|
l-enums))
|
||||||
rhss)))
|
rhss)))
|
||||||
|
|
||||||
;; find-edges : lang -> (hash symbol -o> (setof symbol))
|
|
||||||
(define (find-edges lang)
|
|
||||||
(foldl
|
|
||||||
(λ (nt m)
|
|
||||||
(hash-set
|
|
||||||
m (nt-name nt)
|
|
||||||
(fold-map/set
|
|
||||||
(λ (rhs)
|
|
||||||
(let loop ([pat (rhs-pattern rhs)]
|
|
||||||
[s (set)])
|
|
||||||
(match-a-pattern
|
|
||||||
pat
|
|
||||||
[`any s]
|
|
||||||
[`number s]
|
|
||||||
[`string s]
|
|
||||||
[`natural s]
|
|
||||||
[`integer s]
|
|
||||||
[`real s]
|
|
||||||
[`boolean s]
|
|
||||||
[`variable s]
|
|
||||||
[`(variable-except ,v ...) s]
|
|
||||||
[`(variable-prefix ,v) s]
|
|
||||||
[`variable-not-otherwise-mentioned s]
|
|
||||||
[`hole s]
|
|
||||||
[`(nt ,id)
|
|
||||||
(set-add s id)]
|
|
||||||
[`(name ,name ,pat)
|
|
||||||
(loop pat s)]
|
|
||||||
[`(mismatch-name ,name ,pat)
|
|
||||||
(loop pat s)]
|
|
||||||
[`(in-hole ,p1 ,p2)
|
|
||||||
(set-union (loop p1 s)
|
|
||||||
(loop p2 s))]
|
|
||||||
[`(hide-hole ,p) (loop p s)]
|
|
||||||
[`(side-condition ,p ,g ,e) s]
|
|
||||||
[`(cross ,s) s]
|
|
||||||
[`(list ,sub-pats ...)
|
|
||||||
(fold-map/set
|
|
||||||
(λ (sub-pat)
|
|
||||||
(match sub-pat
|
|
||||||
[`(repeat ,pat ,name ,mismatch)
|
|
||||||
(loop pat s)]
|
|
||||||
[else (loop sub-pat s)]))
|
|
||||||
sub-pats)]
|
|
||||||
[(? (compose not pair?)) s])))
|
|
||||||
(nt-rhs nt))))
|
|
||||||
(hash)
|
|
||||||
lang))
|
|
||||||
|
|
||||||
;; find-cycles : (hashsymbol -o> (setof symbol)) -> (setof symbol)
|
|
||||||
(define (find-cycles edges)
|
|
||||||
(foldl
|
|
||||||
(λ (v s)
|
|
||||||
(if (let rec ([cur v]
|
|
||||||
[seen (set)])
|
|
||||||
(cond [(set-member? seen cur) #t]
|
|
||||||
[else
|
|
||||||
(ormap
|
|
||||||
(λ (next)
|
|
||||||
(rec next
|
|
||||||
(set-add seen cur)))
|
|
||||||
(set->list (hash-ref edges
|
|
||||||
cur)))]))
|
|
||||||
(set-add s v)
|
|
||||||
s))
|
|
||||||
(set)
|
|
||||||
(hash-keys edges)))
|
|
||||||
|
|
||||||
;; calls-rec? : pat (setof symbol) -> bool
|
|
||||||
(define (calls-rec? pat recs)
|
|
||||||
(let rec ([pat pat])
|
|
||||||
(match-a-pattern
|
|
||||||
pat
|
|
||||||
[`any #f]
|
|
||||||
[`number #f]
|
|
||||||
[`string #f]
|
|
||||||
[`natural #f]
|
|
||||||
[`integer #f]
|
|
||||||
[`real #f]
|
|
||||||
[`boolean #f]
|
|
||||||
[`variable #f]
|
|
||||||
[`(variable-except ,s ...) #f]
|
|
||||||
[`(variable-prefix ,s) #f]
|
|
||||||
[`variable-not-otherwise-mentioned #f]
|
|
||||||
[`hole #f]
|
|
||||||
[`(nt ,id)
|
|
||||||
(set-member? recs id)]
|
|
||||||
[`(name ,name ,pat)
|
|
||||||
(rec pat)]
|
|
||||||
[`(mismatch-name ,name ,pat)
|
|
||||||
(rec pat)]
|
|
||||||
[`(in-hole ,p1 ,p2)
|
|
||||||
(or (rec p1)
|
|
||||||
(rec p2))]
|
|
||||||
[`(hide-hole ,p) (rec p)]
|
|
||||||
[`(side-condition ,p ,g ,e) ;; error
|
|
||||||
(unsupported pat)]
|
|
||||||
[`(cross ,s)
|
|
||||||
(unsupported pat)] ;; error
|
|
||||||
[`(list ,sub-pats ...)
|
|
||||||
(ormap (λ (sub-pat)
|
|
||||||
(match sub-pat
|
|
||||||
[`(repeat ,pat ,name ,mismatch)
|
|
||||||
(rec pat)]
|
|
||||||
[else (rec sub-pat)]))
|
|
||||||
sub-pats)]
|
|
||||||
[(? (compose not pair?)) #f])))
|
|
||||||
|
|
||||||
;; fold-map : (a -> setof b) (listof a) -> (setof b)
|
|
||||||
(define (fold-map/set f l)
|
|
||||||
(foldl
|
|
||||||
(λ (x s)
|
|
||||||
(set-union (f x) s))
|
|
||||||
(set)
|
|
||||||
l))
|
|
||||||
|
|
||||||
;; sep-lang : lang -> lang lang
|
|
||||||
;; topologically sorts non-terminals by dependency
|
|
||||||
;; sorts rhs's so that recursive ones go last
|
|
||||||
#;
|
|
||||||
(define (sep-lang lang)
|
|
||||||
(define (filter-edges edges lang)
|
|
||||||
(foldl
|
|
||||||
(λ (nt m)
|
|
||||||
(let ([name (nt-name nt)])
|
|
||||||
(hash-set m name
|
|
||||||
(hash-ref edges name))))
|
|
||||||
(hash)
|
|
||||||
lang))
|
|
||||||
(let* ([edges (find-edges lang)]
|
|
||||||
[cyclic-nts (find-cycles edges)])
|
|
||||||
(let-values ([(cyclic non-cyclic)
|
|
||||||
(partition (λ (nt)
|
|
||||||
(set-member? cyclic-nts (nt-name nt)))
|
|
||||||
lang)])
|
|
||||||
(let ([sorted-left (topo-sort non-cyclic
|
|
||||||
(filter-edges edges non-cyclic))] ;; topological sort
|
|
||||||
[sorted-right (sort-nt-terms cyclic
|
|
||||||
cyclic-nts)] ;; rhs sort
|
|
||||||
)
|
|
||||||
(values sorted-left
|
|
||||||
sorted-right)))))
|
|
||||||
|
|
||||||
;; recursive-rhss : lang (hash symbol -o> (setof symbol)) -> (hash symbol -o> (assoclist rhs bool))
|
|
||||||
(define (recursive-rhss lang recs)
|
|
||||||
(foldl
|
|
||||||
(λ (nt m)
|
|
||||||
(let ([rhs (nt-rhs nt)])
|
|
||||||
(hash-set m (nt-name nt)
|
|
||||||
(map (λ (rhs)
|
|
||||||
(cons rhs
|
|
||||||
(calls-rec? (rhs-pattern rhs)
|
|
||||||
recs)))
|
|
||||||
rhs))))
|
|
||||||
(hash)
|
|
||||||
lang))
|
|
||||||
|
|
||||||
;; topo-sort : lang (hash symbol -o> (setof symbol)) -> lang
|
|
||||||
(define (topo-sort lang edges)
|
|
||||||
(define (find-top rem edges)
|
|
||||||
(let find ([rem rem])
|
|
||||||
(let ([v (car rem)])
|
|
||||||
(let check ([vs (hash-keys edges)])
|
|
||||||
(cond [(empty? vs) v]
|
|
||||||
[(set-member? (hash-ref edges (car vs))
|
|
||||||
v)
|
|
||||||
(find (cdr rem))]
|
|
||||||
[else (check (cdr vs))])))))
|
|
||||||
(let loop ([rem (hash-keys edges)]
|
|
||||||
[edges edges]
|
|
||||||
[out-lang '()])
|
|
||||||
(cond [(empty? rem) out-lang]
|
|
||||||
[else
|
|
||||||
(let ([v (find-top rem edges)])
|
|
||||||
(loop (remove v rem)
|
|
||||||
(hash-remove edges v)
|
|
||||||
(cons
|
|
||||||
(findf
|
|
||||||
(λ (nt)
|
|
||||||
(eq? v (nt-name nt)))
|
|
||||||
lang)
|
|
||||||
out-lang)))])))
|
|
||||||
|
|
||||||
;; sort-nt-terms : lang (setof symbol) -> lang
|
|
||||||
(define (sort-nt-terms lang nts)
|
|
||||||
(let ([recs (recursive-rhss lang nts)])
|
|
||||||
(map
|
|
||||||
(λ (nt)
|
|
||||||
(let ([rec-nts (hash-ref recs (nt-name nt))])
|
|
||||||
(make-nt (nt-name nt)
|
|
||||||
(sort (nt-rhs nt)
|
|
||||||
(λ (r1 r2)
|
|
||||||
(and (not (cdr (assoc r1 rec-nts)))
|
|
||||||
(cdr (assoc r2 rec-nts))))))))
|
|
||||||
lang)))
|
|
||||||
|
|
||||||
(define (pat/enum pat l-enums)
|
(define (pat/enum pat l-enums)
|
||||||
(enum-names pat
|
(enum-names pat
|
||||||
(sep-names pat)
|
(sep-names pat)
|
||||||
l-enums))
|
l-enums))
|
||||||
|
|
||||||
|
(define (map-nt-rhs-pat f nonterminal)
|
||||||
|
(nt (nt-name nonterminal)
|
||||||
|
(map (compose rhs f rhs-pattern)
|
||||||
|
(nt-rhs nonterminal))))
|
||||||
|
|
||||||
|
;; map-names : (symbol -> symbol), (symbol, symbol -> symbol, symbol), pattern -> pattern
|
||||||
|
(define (map-names namef repf pat)
|
||||||
|
(let loop ([pat pat])
|
||||||
|
(match-a-pattern
|
||||||
|
pat
|
||||||
|
[`any pat]
|
||||||
|
[`number pat]
|
||||||
|
[`string pat]
|
||||||
|
[`natural pat]
|
||||||
|
[`integer pat]
|
||||||
|
[`real pat]
|
||||||
|
[`boolean pat]
|
||||||
|
[`variable pat]
|
||||||
|
[`(variable-except ,s ...) pat]
|
||||||
|
[`(variable-prefix ,s) pat]
|
||||||
|
[`variable-not-otherwise-mentioned pat]
|
||||||
|
[`hole pat]
|
||||||
|
[`(nt ,id) pat]
|
||||||
|
[`(name ,n ,pat)
|
||||||
|
`(name ,n ,(namef pat))]
|
||||||
|
[`(mismatch-name ,n ,pat)
|
||||||
|
`(mismatch-name ,n ,(namef pat))]
|
||||||
|
[`(in-hole ,p1 ,p2)
|
||||||
|
`(in-hole ,(loop p1)
|
||||||
|
,(loop p2))]
|
||||||
|
[`(hide-hole ,p)
|
||||||
|
`(hide-hole ,(loop p))]
|
||||||
|
[`(side-condition ,p ,g ,e) pat] ;; not supported
|
||||||
|
[`(cross ,s) pat] ;; not supported
|
||||||
|
[`(list ,sub-pats ...)
|
||||||
|
`(list
|
||||||
|
,@(map (λ (sub-pat)
|
||||||
|
(match sub-pat
|
||||||
|
[`(repeat ,pat ,name ,mismatch)
|
||||||
|
(let-values ([(new-name new-mis)
|
||||||
|
(repf name mismatch)])
|
||||||
|
`(repeat ,(loop pat)
|
||||||
|
,new-name
|
||||||
|
,new-mis))]
|
||||||
|
[else (loop sub-pat)]))
|
||||||
|
sub-pats))]
|
||||||
|
[(? (compose not pair?))
|
||||||
|
pat])))
|
||||||
|
|
||||||
|
;; prepends '_' to all named repeats/mismatch repeats and names all
|
||||||
|
;; unnamed repeats
|
||||||
|
(define (name-all-repeats pat)
|
||||||
|
(let ([i 0])
|
||||||
|
(map-names identity
|
||||||
|
(λ (rep mis)
|
||||||
|
(if (or rep mis)
|
||||||
|
(begin0
|
||||||
|
(values i #f)
|
||||||
|
(set! i (+ i 1)))
|
||||||
|
(values rep mis)))
|
||||||
|
(prefix-names pat))))
|
||||||
|
|
||||||
|
(define (prefix-names pat)
|
||||||
|
(let ([prefix
|
||||||
|
(λ (s)
|
||||||
|
(and s
|
||||||
|
(string->symbol
|
||||||
|
(string-append "_"
|
||||||
|
(symbol->string s)))))])
|
||||||
|
(map-names identity
|
||||||
|
(λ (s1 s2)
|
||||||
|
(values (prefix s1)
|
||||||
|
(prefix s2)))
|
||||||
|
pat)))
|
||||||
|
|
||||||
;; sep-names : single-pattern lang -> named-pats
|
;; sep-names : single-pattern lang -> named-pats
|
||||||
(define (sep-names pat)
|
(define (sep-names pat)
|
||||||
(let loop ([pat pat]
|
(let loop ([pat pat]
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user