Simplified redex unsupported/unimplemented handling.
This commit is contained in:
Max New
parent
70dcd2ecf6
commit
8d9a859d7a
|
|
@ -29,32 +29,32 @@
|
|||
(struct name-ref (name) #:transparent)
|
||||
(struct mismatch-ref (name) #:transparent)
|
||||
|
||||
(struct unimplemented (msg) #:transparent)
|
||||
(struct named-pats (names map) #:transparent
|
||||
) ;; listof symbol and hash symbol -o> (or named, mismatched, named-repeat, mismatch-repeat)
|
||||
|
||||
(define enum-ith decode)
|
||||
|
||||
(define (lang-enumerators lang)
|
||||
(let ([l-enums (make-hash)])
|
||||
(define l-enums (make-hash))
|
||||
(define (enumerate-lang cur-lang enum-f)
|
||||
(for-each
|
||||
(λ (nt)
|
||||
(hash-set! l-enums
|
||||
(nt-name nt)
|
||||
(with-handlers ([exn:fail? fail/enum])
|
||||
(enum-f (nt-rhs nt)
|
||||
l-enums))))
|
||||
cur-lang))
|
||||
(let-values ([(fin-lang rec-lang)
|
||||
(sep-lang lang)])
|
||||
(for-each
|
||||
(λ (nt)
|
||||
(hash-set! l-enums
|
||||
(nt-name nt)
|
||||
(enumerate-rhss (nt-rhs nt)
|
||||
l-enums)))
|
||||
fin-lang)
|
||||
(for-each
|
||||
(λ (nt)
|
||||
(hash-set! l-enums
|
||||
(nt-name nt)
|
||||
(enumerate-lang fin-lang
|
||||
enumerate-rhss)
|
||||
(enumerate-lang rec-lang
|
||||
(λ (rhs enums)
|
||||
(thunk/enum +inf.f
|
||||
(λ ()
|
||||
(enumerate-rhss (nt-rhs nt)
|
||||
l-enums)))))
|
||||
rec-lang))
|
||||
(enumerate-rhss rhs enums)))))
|
||||
|
||||
(lang-enum l-enums)))
|
||||
|
||||
(define (pat-enumerator l-enum pat)
|
||||
|
|
@ -169,9 +169,9 @@
|
|||
(rec p2))]
|
||||
[`(hide-hole ,p) (rec p)]
|
||||
[`(side-condition ,p ,g ,e) ;; error
|
||||
(unsupported/enum pat)]
|
||||
(unsupported pat)]
|
||||
[`(cross ,s)
|
||||
(unsupported/enum pat)] ;; error
|
||||
(unsupported pat)] ;; error
|
||||
[`(list ,sub-pats ...)
|
||||
(ormap (λ (sub-pat)
|
||||
(match sub-pat
|
||||
|
|
@ -313,8 +313,9 @@
|
|||
[`(repeat ,pat #f #f)
|
||||
(loop pat named-pats)]
|
||||
[`(repeat ,pat ,name ,mismatch)
|
||||
(error 'unimplemented)
|
||||
(loop pat
|
||||
(add-unimplemented name "named/mismatched repeat" named-pats))]
|
||||
(unimplemented "named/mismatched repeat"))]
|
||||
[else (loop sub-pat named-pats)]))
|
||||
named-pats
|
||||
sub-pats)]
|
||||
|
|
@ -344,10 +345,6 @@
|
|||
nps]
|
||||
[else
|
||||
(add-named-pats name (named name pat) nps)]))
|
||||
(define (add-unimplemented name msg nps)
|
||||
(add-named-pats name
|
||||
(unimplemented msg)
|
||||
nps))
|
||||
|
||||
(define (add-mismatch n pat nps)
|
||||
(cond [(member-named-pats n nps)
|
||||
|
|
@ -386,9 +383,7 @@
|
|||
[(mismatch? val)
|
||||
(mismatch (mismatch-name val)
|
||||
(reverse
|
||||
(mismatch-val val)))]
|
||||
[(unimplemented? val)
|
||||
val]))))
|
||||
(mismatch-val val)))]))))
|
||||
(hash)
|
||||
(hash->list (named-pats-map nps)))))
|
||||
|
||||
|
|
@ -401,6 +396,7 @@
|
|||
n)))
|
||||
(assoc-named n (cdr l)))]))
|
||||
|
||||
|
||||
(define (enum-names pat nps nt-enums)
|
||||
(let rec ([nps nps]
|
||||
[env (hash)])
|
||||
|
|
@ -466,9 +462,6 @@
|
|||
(hash-set env
|
||||
name
|
||||
terms))))))]
|
||||
[(unimplemented? cur)
|
||||
(error/enum 'unimplemented
|
||||
(unimplemented-msg cur))]
|
||||
[else (error 'unexpected "expected name, mismatch or unimplemented, got: ~a in ~a" cur nps)]))])))
|
||||
|
||||
(define (pat/enum-with-names pat nt-enums named-terms)
|
||||
|
|
@ -490,9 +483,9 @@
|
|||
(except/enum var/enum s)]
|
||||
[`(variable-prefix ,s)
|
||||
;; todo
|
||||
(error/enum 'unimplemented "var-prefix")]
|
||||
(error 'unimplemented "var-prefix")]
|
||||
[`variable-not-otherwise-mentioned
|
||||
(error/enum 'unimplemented "var-not-mentioned")] ;; error
|
||||
(error 'unimplemented "var-not-mentioned")] ;; error
|
||||
[`hole
|
||||
(const/enum the-hole)]
|
||||
[`(nt ,id)
|
||||
|
|
@ -515,9 +508,9 @@
|
|||
[`(hide-hole ,p)
|
||||
(loop p)]
|
||||
[`(side-condition ,p ,g ,e)
|
||||
(unsupported/enum pat)]
|
||||
(unsupported pat)]
|
||||
[`(cross ,s)
|
||||
(unsupported/enum pat)]
|
||||
(unsupported pat)]
|
||||
[`(list ,sub-pats ...)
|
||||
;; enum-list
|
||||
(list/enum
|
||||
|
|
@ -538,9 +531,9 @@
|
|||
(list/enum
|
||||
(build-list n (const (loop pat)))))))]
|
||||
[`(repeat ,pat ,name #f)
|
||||
(error/enum 'unimplemented "named-repeat")]
|
||||
(error 'unimplemented "named-repeat")]
|
||||
[`(repeat ,pat #f ,mismatch)
|
||||
(error/enum 'unimplemented "mismatch-repeat")]
|
||||
(error 'unimplemented "mismatch-repeat")]
|
||||
[else (loop sub-pat)]))
|
||||
sub-pats))]
|
||||
[(? (compose not pair?))
|
||||
|
|
@ -718,3 +711,9 @@
|
|||
(define (map-repeat f r)
|
||||
(repeat (repeat-n r)
|
||||
(map f (repeat-terms r))))
|
||||
|
||||
(define (unsupported pat)
|
||||
(error 'generate-term "#:i-th does not support ~s patterns" pat))
|
||||
|
||||
(define (unimplemented pat)
|
||||
(error 'generate-term "#:i-th does not yet support ~s patterns" pat))
|
||||
|
|
|
|||
|
|
@ -32,9 +32,7 @@
|
|||
nats
|
||||
range/enum
|
||||
nats+/enum
|
||||
|
||||
error/enum
|
||||
unsupported/enum)
|
||||
)
|
||||
|
||||
;; an enum a is a struct of < Nat or +Inf, Nat -> a, a -> Nat >
|
||||
(struct enum
|
||||
|
|
@ -592,14 +590,6 @@
|
|||
t
|
||||
t)))
|
||||
|
||||
(define (error/enum . args)
|
||||
(define (fail n) (apply error args))
|
||||
(enum +inf.0 fail fail))
|
||||
|
||||
(define (unsupported/enum pat)
|
||||
(error/enum 'generate-term "#:i-th does not support ~s patterns" pat))
|
||||
|
||||
|
||||
(module+
|
||||
test
|
||||
(require rackunit)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user