Removed tabs from redex enum code
This commit is contained in:
Max New
parent
d174a0c0a0
commit
e86e47a968
|
|
@ -1,11 +1,11 @@
|
|||
#lang racket/base
|
||||
(require racket/contract
|
||||
racket/list
|
||||
racket/match
|
||||
racket/function
|
||||
racket/list
|
||||
racket/match
|
||||
racket/function
|
||||
"lang-struct.rkt"
|
||||
"match-a-pattern.rkt"
|
||||
"enumerator.rkt")
|
||||
"match-a-pattern.rkt"
|
||||
"enumerator.rkt")
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
|
|
@ -19,18 +19,18 @@
|
|||
|
||||
(define (lang-enumerators nts)
|
||||
(let* ([l-enums (make-hash)]
|
||||
[rec-nt-terms (find-recs nts)]
|
||||
[sorted-nts (sort-nt-terms nts rec-nt-terms)])
|
||||
[rec-nt-terms (find-recs nts)]
|
||||
[sorted-nts (sort-nt-terms nts rec-nt-terms)])
|
||||
(foldl
|
||||
(λ (nt m)
|
||||
(hash-set
|
||||
m
|
||||
(nt-name nt)
|
||||
(with-handlers
|
||||
([exn:fail? fail/enum])
|
||||
(rec-pat/enum `(nt ,(nt-name nt))
|
||||
sorted-nts
|
||||
rec-nt-terms))))
|
||||
(hash-set
|
||||
m
|
||||
(nt-name nt)
|
||||
(with-handlers
|
||||
([exn:fail? fail/enum])
|
||||
(rec-pat/enum `(nt ,(nt-name nt))
|
||||
sorted-nts
|
||||
rec-nt-terms))))
|
||||
(hash)
|
||||
sorted-nts)))
|
||||
|
||||
|
|
@ -39,14 +39,14 @@
|
|||
|
||||
(define (pat-enumerator lang-enums pat)
|
||||
(enum-names pat
|
||||
(sep-names pat)
|
||||
lang-enums))
|
||||
(sep-names pat)
|
||||
lang-enums))
|
||||
|
||||
(define (rec-pat/enum pat nts rec-nt-terms)
|
||||
(enum-names pat
|
||||
nts
|
||||
(sep-names pat)
|
||||
rec-nt-terms))
|
||||
nts
|
||||
(sep-names pat)
|
||||
rec-nt-terms))
|
||||
|
||||
|
||||
;; find-recs : lang -> (hash symbol -o> (assoclist rhs bool))
|
||||
|
|
@ -57,50 +57,50 @@
|
|||
[(n) (is-rec? n (hash))]
|
||||
[(nt seen)
|
||||
(or (seen? seen (nt-name nt))
|
||||
(ormap
|
||||
(λ (rhs)
|
||||
(let rec ([pat (rhs-pattern rhs)])
|
||||
(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)
|
||||
(is-rec? (make-nt
|
||||
id
|
||||
(lookup nt-pats id))
|
||||
(add-seen seen
|
||||
(nt-name nt)))]
|
||||
[`(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/enum pat)]
|
||||
[`(cross ,s)
|
||||
(unsupported/enum 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])))
|
||||
(nt-rhs nt)))]))
|
||||
(ormap
|
||||
(λ (rhs)
|
||||
(let rec ([pat (rhs-pattern rhs)])
|
||||
(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)
|
||||
(is-rec? (make-nt
|
||||
id
|
||||
(lookup nt-pats id))
|
||||
(add-seen seen
|
||||
(nt-name nt)))]
|
||||
[`(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/enum pat)]
|
||||
[`(cross ,s)
|
||||
(unsupported/enum 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])))
|
||||
(nt-rhs nt)))]))
|
||||
(define (calls-rec? rhs recs)
|
||||
(let rec ([pat (rhs-pattern rhs)])
|
||||
(match-a-pattern
|
||||
|
|
@ -118,43 +118,43 @@
|
|||
[`variable-not-otherwise-mentioned #f]
|
||||
[`hole #f]
|
||||
[`(nt ,id)
|
||||
(hash-ref recs id)]
|
||||
(hash-ref recs id)]
|
||||
[`(name ,name ,pat)
|
||||
(rec pat)]
|
||||
(rec pat)]
|
||||
[`(mismatch-name ,name ,pat)
|
||||
(rec pat)]
|
||||
(rec pat)]
|
||||
[`(in-hole ,p1 ,p2)
|
||||
(or (rec p1)
|
||||
(rec p2))]
|
||||
(or (rec p1)
|
||||
(rec p2))]
|
||||
[`(hide-hole ,p) (rec p)]
|
||||
[`(side-condition ,p ,g ,e) ;; error
|
||||
(rec p)]
|
||||
(rec p)]
|
||||
[`(cross ,s)
|
||||
(unsupported/enum pat)] ;; error
|
||||
(unsupported/enum pat)] ;; error
|
||||
[`(list ,sub-pats ...)
|
||||
(ormap (λ (sub-pat)
|
||||
(match sub-pat
|
||||
[`(repeat ,pat ,name ,mismatch)
|
||||
(rec pat)]
|
||||
[else (rec sub-pat)]))
|
||||
sub-pats)]
|
||||
(ormap (λ (sub-pat)
|
||||
(match sub-pat
|
||||
[`(repeat ,pat ,name ,mismatch)
|
||||
(rec pat)]
|
||||
[else (rec sub-pat)]))
|
||||
sub-pats)]
|
||||
[(? (compose not pair?)) #f])))
|
||||
(define (seen? m s)
|
||||
(hash-ref m s #f))
|
||||
(define (add-seen m s)
|
||||
(hash-set m s #t))
|
||||
(let ([recs
|
||||
(foldl
|
||||
(λ (nt m)
|
||||
(hash-set m (nt-name nt) (is-rec? nt)))
|
||||
(hash) nt-pats)])
|
||||
(foldl
|
||||
(λ (nt m)
|
||||
(hash-set m (nt-name nt) (is-rec? nt)))
|
||||
(hash) nt-pats)])
|
||||
(foldl
|
||||
(λ (nt m)
|
||||
(let ([rhs (nt-rhs nt)])
|
||||
(hash-set m (nt-name nt)
|
||||
(map (λ (rhs)
|
||||
(cons rhs (calls-rec? rhs recs)))
|
||||
rhs))))
|
||||
(let ([rhs (nt-rhs nt)])
|
||||
(hash-set m (nt-name nt)
|
||||
(map (λ (rhs)
|
||||
(cons rhs (calls-rec? rhs recs)))
|
||||
rhs))))
|
||||
(hash)
|
||||
nt-pats)))
|
||||
|
||||
|
|
@ -163,17 +163,17 @@
|
|||
(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))))))))
|
||||
(make-nt (nt-name nt)
|
||||
(sort (nt-rhs nt)
|
||||
(λ (r1 r2)
|
||||
(and (not (cdr (assoc r1 rec-nts)))
|
||||
(cdr (assoc r2 rec-nts))))))))
|
||||
nt-pats))
|
||||
|
||||
;; sep-names : single-pattern lang -> (assoclist symbol pattern)
|
||||
(define (sep-names pat)
|
||||
(let loop ([pat pat]
|
||||
[named-pats '()])
|
||||
[named-pats '()])
|
||||
(match-a-pattern
|
||||
pat
|
||||
[`any named-pats]
|
||||
|
|
@ -192,13 +192,13 @@
|
|||
[`(nt ,id) named-pats]
|
||||
[`(name ,name ,pat)
|
||||
(loop pat
|
||||
(add-if-new name pat named-pats))]
|
||||
(add-if-new name pat named-pats))]
|
||||
[`(mismatch-name ,name ,pat)
|
||||
(loop pat
|
||||
(add-if-new name pat named-pats))]
|
||||
(add-if-new name pat named-pats))]
|
||||
[`(in-hole ,p1 ,p2)
|
||||
(loop p2
|
||||
(loop p1 named-pats))]
|
||||
(loop p1 named-pats))]
|
||||
[`(hide-hole ,p) (loop p named-pats)]
|
||||
[`(side-condition ,p ,g ,e) ;; error
|
||||
(unsupported/enum pat)]
|
||||
|
|
@ -206,263 +206,263 @@
|
|||
(unsupported/enum pat)] ;; error
|
||||
[`(list ,sub-pats ...)
|
||||
(foldl (λ (sub-pat named-pats)
|
||||
(match sub-pat
|
||||
;; unnamed repeat
|
||||
[`(repeat ,pat #f #f)
|
||||
(loop pat named-pats)]
|
||||
;; named repeat
|
||||
[`(repeat ,pat ,name #f)
|
||||
(loop pat
|
||||
(add-if-new name 'name-r named-pats))]
|
||||
;; mismatch named repeat
|
||||
[`(repeat ,pat #f ,mismatch)
|
||||
(loop pat
|
||||
(add-if-new mismatch 'mismatch-r named-pats))]
|
||||
;; normal subpattern
|
||||
[else (loop sub-pat named-pats)]))
|
||||
named-pats
|
||||
sub-pats)]
|
||||
(match sub-pat
|
||||
;; unnamed repeat
|
||||
[`(repeat ,pat #f #f)
|
||||
(loop pat named-pats)]
|
||||
;; named repeat
|
||||
[`(repeat ,pat ,name #f)
|
||||
(loop pat
|
||||
(add-if-new name 'name-r named-pats))]
|
||||
;; mismatch named repeat
|
||||
[`(repeat ,pat #f ,mismatch)
|
||||
(loop pat
|
||||
(add-if-new mismatch 'mismatch-r named-pats))]
|
||||
;; normal subpattern
|
||||
[else (loop sub-pat named-pats)]))
|
||||
named-pats
|
||||
sub-pats)]
|
||||
[(? (compose not pair?))
|
||||
named-pats])))
|
||||
|
||||
(define (add-if-new k v l)
|
||||
(cond [(assoc k l) l]
|
||||
[else (cons `(,k ,v) l)]))
|
||||
[else (cons `(,k ,v) l)]))
|
||||
|
||||
(define enum-names
|
||||
(case-lambda
|
||||
[(pat named-pats nts)
|
||||
(enum-names-with
|
||||
(λ (pat named)
|
||||
(pat/enum-with-names pat nts named))
|
||||
(pat/enum-with-names pat nts named))
|
||||
pat named-pats)]
|
||||
[(pat nts named-pats rec-nt-terms)
|
||||
(enum-names-with
|
||||
(λ (pat named)
|
||||
(pat/enum-with-names pat nts named rec-nt-terms))
|
||||
(pat/enum-with-names pat nts named rec-nt-terms))
|
||||
pat named-pats)]))
|
||||
|
||||
(define (enum-names-with f pat named-pats)
|
||||
(let rec ([named-pats named-pats]
|
||||
[env (hash)])
|
||||
[env (hash)])
|
||||
(cond [(null? named-pats) (f pat env)]
|
||||
[else
|
||||
(match
|
||||
(car named-pats)
|
||||
;; named repeat
|
||||
[`(,name name-r)
|
||||
(error/enum 'unimplemented "named-repeat")]
|
||||
;; mismatch repeat
|
||||
[`(,name mismatch-r)
|
||||
(error/enum 'unimplemented "mismatch-repeat")]
|
||||
[`(,name ,pat mismatch)
|
||||
(error/enum 'unimplemented "mismatch")]
|
||||
;; named
|
||||
[`(,name ,pat)
|
||||
(map/enum ;; loses bijection
|
||||
cdr
|
||||
(λ (x) (cons name x))
|
||||
(dep/enum
|
||||
(f pat env)
|
||||
(λ (term)
|
||||
(rec (cdr named-pats)
|
||||
(hash-set env
|
||||
name
|
||||
term)))))]
|
||||
[else (error 'bad-assoc)])])))
|
||||
[else
|
||||
(match
|
||||
(car named-pats)
|
||||
;; named repeat
|
||||
[`(,name name-r)
|
||||
(error/enum 'unimplemented "named-repeat")]
|
||||
;; mismatch repeat
|
||||
[`(,name mismatch-r)
|
||||
(error/enum 'unimplemented "mismatch-repeat")]
|
||||
[`(,name ,pat mismatch)
|
||||
(error/enum 'unimplemented "mismatch")]
|
||||
;; named
|
||||
[`(,name ,pat)
|
||||
(map/enum ;; loses bijection
|
||||
cdr
|
||||
(λ (x) (cons name x))
|
||||
(dep/enum
|
||||
(f pat env)
|
||||
(λ (term)
|
||||
(rec (cdr named-pats)
|
||||
(hash-set env
|
||||
name
|
||||
term)))))]
|
||||
[else (error 'bad-assoc)])])))
|
||||
|
||||
(define pat/enum-with-names
|
||||
(case-lambda
|
||||
[(pat nt-enums named-terms)
|
||||
(let loop ([pat pat])
|
||||
(match-a-pattern
|
||||
pat
|
||||
[`any
|
||||
(sum/enum
|
||||
any/enum
|
||||
(listof/enum any/enum))]
|
||||
[`number num/enum]
|
||||
[`string string/enum]
|
||||
[`natural natural/enum]
|
||||
[`integer integer/enum]
|
||||
[`real real/enum]
|
||||
[`boolean bool/enum]
|
||||
[`variable var/enum]
|
||||
[`(variable-except ,s ...)
|
||||
;; todo
|
||||
(error/enum 'unimplemented "var-except")]
|
||||
[`(variable-prefix ,s)
|
||||
;; todo
|
||||
(error/enum 'unimplemented "var-prefix")]
|
||||
[`variable-not-otherwise-mentioned
|
||||
(error/enum 'unimplemented "var-not-mentioned")] ;; error
|
||||
[`hole
|
||||
(const/enum 'hole)]
|
||||
[`(nt ,id)
|
||||
(hash-ref nt-enums id)]
|
||||
[`(name ,name ,pat)
|
||||
(const/enum (hash-ref named-terms name))]
|
||||
[`(mismatch-name ,name ,pat)
|
||||
(error/enum 'unimplemented "mismatch-name")]
|
||||
[`(in-hole ,p1 ,p2) ;; untested
|
||||
(map/enum
|
||||
(λ (t1-t2) ;; loses bijection
|
||||
(plug-hole (car t1-t2)
|
||||
(cdr t1-t2)))
|
||||
(λ (plugged)
|
||||
(cons 'hole plugged))
|
||||
(prod/enum
|
||||
(loop p1)
|
||||
(loop p2)))]
|
||||
[`(hide-hole ,p)
|
||||
(loop p)]
|
||||
[`(side-condition ,p ,g ,e)
|
||||
(unsupported/enum pat)]
|
||||
[`(cross ,s)
|
||||
(unsupported/enum pat)]
|
||||
[`(list ,sub-pats ...)
|
||||
;; enum-list
|
||||
(map/enum
|
||||
flatten-1
|
||||
identity
|
||||
(list/enum
|
||||
(map
|
||||
(λ (sub-pat)
|
||||
(match sub-pat
|
||||
[`(repeat ,pat #f #f)
|
||||
(map/enum
|
||||
cdr
|
||||
(λ (ts)
|
||||
(cons (length ts)
|
||||
ts))
|
||||
(dep/enum
|
||||
nats
|
||||
(λ (n)
|
||||
(list/enum
|
||||
(build-list n (const (loop pat)))))))]
|
||||
[`(repeat ,pat ,name #f)
|
||||
(error/enum 'unimplemented "named-repeat")]
|
||||
[`(repeat ,pat #f ,mismatch)
|
||||
(error/enum 'unimplemented "mismatch-repeat")]
|
||||
[else (map/enum
|
||||
pat
|
||||
[`any
|
||||
(sum/enum
|
||||
any/enum
|
||||
(listof/enum any/enum))]
|
||||
[`number num/enum]
|
||||
[`string string/enum]
|
||||
[`natural natural/enum]
|
||||
[`integer integer/enum]
|
||||
[`real real/enum]
|
||||
[`boolean bool/enum]
|
||||
[`variable var/enum]
|
||||
[`(variable-except ,s ...)
|
||||
;; todo
|
||||
(error/enum 'unimplemented "var-except")]
|
||||
[`(variable-prefix ,s)
|
||||
;; todo
|
||||
(error/enum 'unimplemented "var-prefix")]
|
||||
[`variable-not-otherwise-mentioned
|
||||
(error/enum 'unimplemented "var-not-mentioned")] ;; error
|
||||
[`hole
|
||||
(const/enum 'hole)]
|
||||
[`(nt ,id)
|
||||
(hash-ref nt-enums id)]
|
||||
[`(name ,name ,pat)
|
||||
(const/enum (hash-ref named-terms name))]
|
||||
[`(mismatch-name ,name ,pat)
|
||||
(error/enum 'unimplemented "mismatch-name")]
|
||||
[`(in-hole ,p1 ,p2) ;; untested
|
||||
(map/enum
|
||||
(λ (t1-t2) ;; loses bijection
|
||||
(plug-hole (car t1-t2)
|
||||
(cdr t1-t2)))
|
||||
(λ (plugged)
|
||||
(cons 'hole plugged))
|
||||
(prod/enum
|
||||
(loop p1)
|
||||
(loop p2)))]
|
||||
[`(hide-hole ,p)
|
||||
(loop p)]
|
||||
[`(side-condition ,p ,g ,e)
|
||||
(unsupported/enum pat)]
|
||||
[`(cross ,s)
|
||||
(unsupported/enum pat)]
|
||||
[`(list ,sub-pats ...)
|
||||
;; enum-list
|
||||
(map/enum
|
||||
flatten-1
|
||||
identity
|
||||
(list/enum
|
||||
(map
|
||||
(λ (sub-pat)
|
||||
(match sub-pat
|
||||
[`(repeat ,pat #f #f)
|
||||
(map/enum
|
||||
cdr
|
||||
(λ (ts)
|
||||
(cons (length ts)
|
||||
ts))
|
||||
(dep/enum
|
||||
nats
|
||||
(λ (n)
|
||||
(list/enum
|
||||
(build-list n (const (loop pat)))))))]
|
||||
[`(repeat ,pat ,name #f)
|
||||
(error/enum 'unimplemented "named-repeat")]
|
||||
[`(repeat ,pat #f ,mismatch)
|
||||
(error/enum 'unimplemented "mismatch-repeat")]
|
||||
[else (map/enum
|
||||
(λ (x) (list x))
|
||||
car
|
||||
(loop sub-pat))]))
|
||||
sub-pats)))]
|
||||
[(? (compose not pair?))
|
||||
(const/enum pat)]))]
|
||||
sub-pats)))]
|
||||
[(? (compose not pair?))
|
||||
(const/enum pat)]))]
|
||||
[(pat nts named-terms rec-nt-terms)
|
||||
(let loop ([pat pat])
|
||||
(match-a-pattern
|
||||
pat
|
||||
[`any
|
||||
(sum/enum
|
||||
any/enum
|
||||
(listof/enum any/enum))]
|
||||
[`number num/enum]
|
||||
[`string string/enum]
|
||||
[`natural natural/enum]
|
||||
[`integer integer/enum]
|
||||
[`real real/enum]
|
||||
[`boolean bool/enum]
|
||||
[`variable var/enum]
|
||||
[`(variable-except ,s ...)
|
||||
;; todo
|
||||
(error/enum 'unimplemented "var except")]
|
||||
[`(variable-prefix ,s)
|
||||
;; todo
|
||||
(error/enum 'unimplemented "var prefix")]
|
||||
[`variable-not-otherwise-mentioned
|
||||
(error/enum 'unimplemented "var not otherwise mentioned")]
|
||||
[`hole
|
||||
(const/enum 'hole)]
|
||||
[`(nt ,id)
|
||||
(let ([rhss (lookup nts id)])
|
||||
(apply sum/enum
|
||||
(map
|
||||
(λ (rhs)
|
||||
(cond [(cdr (assoc rhs (hash-ref rec-nt-terms id)))
|
||||
(thunk/enum
|
||||
+inf.f
|
||||
(λ ()
|
||||
(rec-pat/enum (rhs-pattern rhs)
|
||||
nts
|
||||
rec-nt-terms)))]
|
||||
[else
|
||||
(rec-pat/enum (rhs-pattern rhs)
|
||||
nts
|
||||
rec-nt-terms)]))
|
||||
rhss)))]
|
||||
[`(name ,name ,pat)
|
||||
(const/enum (hash-ref named-terms name))]
|
||||
[`(mismatch-name ,name ,pat)
|
||||
(error/enum 'unimplemented "mismatch-name")]
|
||||
[`(in-hole ,p1 ,p2) ;; untested
|
||||
(map/enum
|
||||
(λ (t1-t2)
|
||||
(decomposition (car t1-t2)
|
||||
(cdr t1-t2)))
|
||||
(λ (decomp)
|
||||
(cons (decomposition-ctx decomp)
|
||||
(decomposition-term decomp)))
|
||||
(prod/enum
|
||||
(loop p1)
|
||||
(loop p2)))]
|
||||
[`(hide-hole ,p)
|
||||
;; todo
|
||||
(loop p)]
|
||||
[`(side-condition ,p ,g ,e)
|
||||
(unsupported/enum pat)]
|
||||
[`(cross ,s)
|
||||
(unsupported/enum pat)]
|
||||
[`(list ,sub-pats ...)
|
||||
;; enum-list
|
||||
(map/enum
|
||||
flatten-1
|
||||
identity
|
||||
(list/enum
|
||||
(map
|
||||
(λ (sub-pat)
|
||||
(match sub-pat
|
||||
[`(repeat ,pat #f #f)
|
||||
(map/enum
|
||||
cdr
|
||||
(λ (ts)
|
||||
(cons (length ts)
|
||||
ts))
|
||||
(dep/enum
|
||||
nats
|
||||
(λ (n)
|
||||
(list/enum
|
||||
(build-list n (const (loop pat)))))))]
|
||||
[`(repeat ,pat ,name #f)
|
||||
(error/enum 'unimplemented "named-repeat")]
|
||||
[`(repeat ,pat #f ,mismatch)
|
||||
(error/enum 'unimplemented "mismatch-repeat")]
|
||||
[else (map/enum
|
||||
pat
|
||||
[`any
|
||||
(sum/enum
|
||||
any/enum
|
||||
(listof/enum any/enum))]
|
||||
[`number num/enum]
|
||||
[`string string/enum]
|
||||
[`natural natural/enum]
|
||||
[`integer integer/enum]
|
||||
[`real real/enum]
|
||||
[`boolean bool/enum]
|
||||
[`variable var/enum]
|
||||
[`(variable-except ,s ...)
|
||||
;; todo
|
||||
(error/enum 'unimplemented "var except")]
|
||||
[`(variable-prefix ,s)
|
||||
;; todo
|
||||
(error/enum 'unimplemented "var prefix")]
|
||||
[`variable-not-otherwise-mentioned
|
||||
(error/enum 'unimplemented "var not otherwise mentioned")]
|
||||
[`hole
|
||||
(const/enum 'hole)]
|
||||
[`(nt ,id)
|
||||
(let ([rhss (lookup nts id)])
|
||||
(apply sum/enum
|
||||
(map
|
||||
(λ (rhs)
|
||||
(cond [(cdr (assoc rhs (hash-ref rec-nt-terms id)))
|
||||
(thunk/enum
|
||||
+inf.f
|
||||
(λ ()
|
||||
(rec-pat/enum (rhs-pattern rhs)
|
||||
nts
|
||||
rec-nt-terms)))]
|
||||
[else
|
||||
(rec-pat/enum (rhs-pattern rhs)
|
||||
nts
|
||||
rec-nt-terms)]))
|
||||
rhss)))]
|
||||
[`(name ,name ,pat)
|
||||
(const/enum (hash-ref named-terms name))]
|
||||
[`(mismatch-name ,name ,pat)
|
||||
(error/enum 'unimplemented "mismatch-name")]
|
||||
[`(in-hole ,p1 ,p2) ;; untested
|
||||
(map/enum
|
||||
(λ (t1-t2)
|
||||
(decomposition (car t1-t2)
|
||||
(cdr t1-t2)))
|
||||
(λ (decomp)
|
||||
(cons (decomposition-ctx decomp)
|
||||
(decomposition-term decomp)))
|
||||
(prod/enum
|
||||
(loop p1)
|
||||
(loop p2)))]
|
||||
[`(hide-hole ,p)
|
||||
;; todo
|
||||
(loop p)]
|
||||
[`(side-condition ,p ,g ,e)
|
||||
(unsupported/enum pat)]
|
||||
[`(cross ,s)
|
||||
(unsupported/enum pat)]
|
||||
[`(list ,sub-pats ...)
|
||||
;; enum-list
|
||||
(map/enum
|
||||
flatten-1
|
||||
identity
|
||||
(list/enum
|
||||
(map
|
||||
(λ (sub-pat)
|
||||
(match sub-pat
|
||||
[`(repeat ,pat #f #f)
|
||||
(map/enum
|
||||
cdr
|
||||
(λ (ts)
|
||||
(cons (length ts)
|
||||
ts))
|
||||
(dep/enum
|
||||
nats
|
||||
(λ (n)
|
||||
(list/enum
|
||||
(build-list n (const (loop pat)))))))]
|
||||
[`(repeat ,pat ,name #f)
|
||||
(error/enum 'unimplemented "named-repeat")]
|
||||
[`(repeat ,pat #f ,mismatch)
|
||||
(error/enum 'unimplemented "mismatch-repeat")]
|
||||
[else (map/enum
|
||||
list
|
||||
cdr
|
||||
(loop sub-pat))]))
|
||||
sub-pats)))]
|
||||
[(? (compose not pair?))
|
||||
(const/enum pat)]))]))
|
||||
sub-pats)))]
|
||||
[(? (compose not pair?))
|
||||
(const/enum pat)]))]))
|
||||
|
||||
(define (flatten-1 xs)
|
||||
(append-map
|
||||
(λ (x)
|
||||
(if (or (pair? x)
|
||||
(null? x))
|
||||
x
|
||||
(list x)))
|
||||
(null? x))
|
||||
x
|
||||
(list x)))
|
||||
xs))
|
||||
|
||||
;; lookup : lang symbol -> (listof rhs)
|
||||
(define (lookup nts name)
|
||||
(let rec ([nts nts])
|
||||
(cond [(null? nts) (error 'unkown-nt)]
|
||||
[(eq? name (nt-name (car nts)))
|
||||
(nt-rhs (car nts))]
|
||||
[else (rec (cdr nts))])))
|
||||
[(eq? name (nt-name (car nts)))
|
||||
(nt-rhs (car nts))]
|
||||
[else (rec (cdr nts))])))
|
||||
|
||||
(define natural/enum nats)
|
||||
|
||||
|
|
@ -480,15 +480,15 @@
|
|||
|
||||
(define integer/enum
|
||||
(sum/enum nats
|
||||
(map/enum (λ (n) (- (+ n 1)))
|
||||
(λ (n) (- (- n) 1))
|
||||
nats)))
|
||||
(map/enum (λ (n) (- (+ n 1)))
|
||||
(λ (n) (- (- n) 1))
|
||||
nats)))
|
||||
|
||||
(define real/enum (from-list/enum '(0.0 1.5 123.112354)))
|
||||
(define num/enum
|
||||
(sum/enum natural/enum
|
||||
integer/enum
|
||||
real/enum))
|
||||
integer/enum
|
||||
real/enum))
|
||||
|
||||
(define bool/enum
|
||||
(from-list/enum '(#t #f)))
|
||||
|
|
@ -501,15 +501,15 @@
|
|||
|
||||
(define any/enum
|
||||
(sum/enum num/enum
|
||||
string/enum
|
||||
bool/enum
|
||||
var/enum))
|
||||
string/enum
|
||||
bool/enum
|
||||
var/enum))
|
||||
|
||||
(define (plug-hole ctx term)
|
||||
(let loop ([ctx ctx])
|
||||
(match
|
||||
ctx
|
||||
['hole term]
|
||||
[`(,ts ...)
|
||||
(map loop ts)]
|
||||
[x x])))
|
||||
ctx
|
||||
['hole term]
|
||||
[`(,ts ...)
|
||||
(map loop ts)]
|
||||
[x x])))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user