From 3dfab4d0aa5485312b22ce50d56d394b77e0a386 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 27 Mar 2013 18:54:50 -0400
Subject: [PATCH] factor out create-ehpat code

---
 .../syntax/parse/private/rep-patterns.rkt     | 17 ++++++++
 collects/syntax/parse/private/rep.rkt         | 39 +++++--------------
 2 files changed, 27 insertions(+), 29 deletions(-)

diff --git a/collects/syntax/parse/private/rep-patterns.rkt b/collects/syntax/parse/private/rep-patterns.rkt
index 0db64f339c..c9a725a66c 100644
--- a/collects/syntax/parse/private/rep-patterns.rkt
+++ b/collects/syntax/parse/private/rep-patterns.rkt
@@ -384,6 +384,23 @@ A SideClause is one of
 
 ;; ----
 
+(define (create-ehpat head repc)
+  (let* ([iattrs0 (pattern-attrs head)]
+         [iattrs (repc-adjust-attrs iattrs0 repc)])
+    (ehpat iattrs head repc)))
+
+(define (repc-adjust-attrs iattrs repc)
+  (cond [(rep:once? repc)
+         iattrs]
+        [(rep:optional? repc)
+         (map attr-make-uncertain iattrs)]
+        [(or (rep:bounds? repc) (eq? #f repc))
+         (map increase-depth iattrs)]
+        [else
+         (error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)]))
+
+;; ----
+
 (define (action/head-pattern->list-pattern p)
   (cond [(action-pattern? p)
          (create-pat:action p (create-pat:any))]
diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt
index 01045de8a3..53ae5bffa7 100644
--- a/collects/syntax/parse/private/rep.rkt
+++ b/collects/syntax/parse/private/rep.rkt
@@ -588,9 +588,9 @@
        (for/list ([alt (in-list (eh-alternative-set-alts eh-alt-set))])
          (let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]
                 [attr-count (length iattrs)])
-           (list (make ehpat (repc-adjust-attrs iattrs (eh-alternative-repc alt))
-                       (create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f)
-                       (eh-alternative-repc alt))
+           (list (create-ehpat
+                  (create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f)
+                  (eh-alternative-repc alt))
                  (replace-eh-alternative-attrs
                   alt (iattrs->sattrs iattrs))))))]
     [(~or . _)
@@ -612,18 +612,7 @@
      (list (parse*-ehpat/bounds stx decls))]
     [_
      (let ([head (parse-head-pattern stx decls)])
-       (list (list (make ehpat (map increase-depth (pattern-attrs head))
-                         head
-                         #f)
-                   stx)))]))
-
-(define (repc-adjust-attrs iattrs repc)
-  (cond [(or (rep:once? repc) (rep:optional? repc))
-         iattrs]
-        [(or (rep:bounds? repc) (eq? #f repc))
-         (map increase-depth iattrs)]
-        [else
-         (error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)]))
+       (list (list (create-ehpat head #f) stx)))]))
 
 (define (replace-eh-alternative-attrs alt sattrs)
   (match alt
@@ -945,10 +934,7 @@
 (define (parse-pat:plus-dots stx head tail decls)
   (define headp (parse-head-pattern head decls))
   (define tailp (parse-single-pattern tail decls))
-  (define head/rep
-    (make-ehpat (map increase-depth (pattern-attrs headp))
-                headp
-                (make-rep:bounds 1 +inf.0 #f #f #f)))
+  (define head/rep (create-ehpat headp (make-rep:bounds 1 +inf.0 #f #f #f)))
   (create-pat:dots (list head/rep) tailp))
 
 (define (parse-pat:bind stx decls)
@@ -1080,9 +1066,7 @@
 (define (parse*-ehpat/optional stx decls)
   (define-values (head-stx head iattrs name too-many-msg defaults)
     (parse*-optional-pattern stx decls eh-optional-directive-table))
-  (list (make ehpat iattrs
-              head
-              (make rep:optional name too-many-msg defaults))
+  (list (create-ehpat head (make rep:optional name too-many-msg defaults))
         head-stx))
 
 ;; parse*-ehpat/once : stx DeclEnv -> (list EllipsisHeadPattern stx)
@@ -1102,9 +1086,7 @@
              (options-select-value chunks '#:too-many #:default #'#f)]
             [name
              (options-select-value chunks '#:name #:default #'#f)])
-       (list (make ehpat (pattern-attrs head)
-                   head
-                   (make rep:once name too-few-msg too-many-msg))
+       (list (create-ehpat head (make rep:once name too-few-msg too-many-msg))
              #'p))]))
 
 ;; parse*-ehpat/bounds : stx DeclEnv -> (list EllipsisHeadPattern stx)
@@ -1135,10 +1117,9 @@
                (options-select-value chunks '#:too-many #:default #'#f)]
               [name
                (options-select-value chunks '#:name #:default #'#f)])
-         (list (make ehpat (map increase-depth (pattern-attrs head))
-                     head
-                     (make rep:bounds #'min #'max
-                           name too-few-msg too-many-msg))
+         (list (create-ehpat head
+                             (make rep:bounds #'min #'max
+                                   name too-few-msg too-many-msg))
                #'p)))]))
 
 ;; -----