Simplified redex unsupported/unimplemented handling.

pkgs/redex/private/enum.rkt

@@ -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
+    (enumerate-lang fin-lang
-       (λ (nt)
+                    enumerate-rhss)
-          (hash-set! l-enums
+    (enumerate-lang rec-lang
-                     (nt-name nt)
+                    (λ (rhs enums)
-                     (enumerate-rhss (nt-rhs nt)
-                                     l-enums)))
-       fin-lang)
-      (for-each
-       (λ (nt)
-          (hash-set! l-enums
-                     (nt-name nt)
                        (thunk/enum +inf.f
                                    (λ ()
-                                    (enumerate-rhss (nt-rhs nt)
+                                      (enumerate-rhss rhs enums)))))
-                                                    l-enums)))))
+
-       rec-lang))
     (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)))]
+                                                (mismatch-val val)))]))))
-                                    [(unimplemented? 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))

pkgs/redex/private/enumerator.rkt

@@ -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)