From f83784452eab00a405360c7b9711cb04fe19d529 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 2 Jul 2010 10:06:32 -0500
Subject: [PATCH] made ->d's optional argument spec itself optional

---
 collects/racket/contract/private/arrow.rkt    | 125 ++++++++++--------
 .../scribblings/reference/contracts.scrbl     |   9 +-
 collects/tests/racket/contract-test.rktl      |  58 ++++++++
 3 files changed, 133 insertions(+), 59 deletions(-)

diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt
index 7d785df945..1b8863cee4 100644
--- a/collects/racket/contract/private/arrow.rkt
+++ b/collects/racket/contract/private/arrow.rkt
@@ -690,7 +690,19 @@ v4 todo:
 
 ;; parses everything after the mandatory and optional doms in a ->d contract
 (define-for-syntax (parse-leftover stx leftover)
-  (let*-values ([(id/rest-id leftover) 
+  (let*-values ([(raw-optional-doms leftover)
+                 (syntax-case leftover ()
+                   [(kwd . leftover2)
+                    (keyword? (syntax-e #'kwd))
+                    (values '() leftover)]
+                   [(dep-range)
+                    (values '() leftover)]
+                   [(dep-range #:post-cond expr)
+                    (values '() leftover)]
+                   [((opts ...) . rest)
+                    (values #'(opts ...) #'rest)]
+                   [_ (values '() leftover)])]
+                [(id/rest-id leftover) 
                  (syntax-case leftover ()
                    [(#:rest id rest-expr . leftover)
                     (and (identifier? #'id)
@@ -724,7 +736,7 @@ v4 todo:
                    [_ (values #f leftover)])])
     (syntax-case leftover ()
       [() 
-       (values id/rest-id pre-cond range post-cond)]
+       (values raw-optional-doms id/rest-id pre-cond range post-cond)]
       [_ 
        (raise-syntax-error #f "bad syntax" stx)])))
 
@@ -771,24 +783,23 @@ v4 todo:
 (define-syntax (->d stx)
   (syntax-case stx ()
     [(_ (raw-mandatory-doms ...)
-        (raw-optional-doms ...)
         .
         leftover)
-     (with-syntax ([(([mandatory-regular-id mandatory-doms] ... ) ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom)] ...)) 
-                    (verify-->d-structure stx (split-doms stx '->d #'(raw-mandatory-doms ...)))]
-                   [(([optional-regular-id optional-doms] ... ) ([optional-kwd (optional-kwd-id optional-kwd-dom)] ...))
-                    (verify-->d-structure stx (split-doms stx '->d #'(raw-optional-doms ...)))])
-       (with-syntax ([((kwd kwd-id) ...)
-                      (sort-keywords 
-                       stx
-                       (syntax->list
-                        #'((optional-kwd optional-kwd-id) ...
-                           (mandatory-kwd mandatory-kwd-id) ...)))]
-                     [(this-parameter ...)
-                      (make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
-                                                (car (generate-temporaries '(this)))
-                                                (datum->syntax stx 'this #f)))])
-         (let-values ([(id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)])
+     (let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)])
+       (with-syntax ([(([mandatory-regular-id mandatory-doms] ... ) ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom)] ...)) 
+                      (verify-->d-structure stx (split-doms stx '->d #'(raw-mandatory-doms ...)))]
+                     [(([optional-regular-id optional-doms] ... ) ([optional-kwd (optional-kwd-id optional-kwd-dom)] ...))
+                      (verify-->d-structure stx (split-doms stx '->d raw-optional-doms))])
+         (with-syntax ([((kwd kwd-id) ...)
+                        (sort-keywords 
+                         stx
+                         (syntax->list
+                          #'((optional-kwd optional-kwd-id) ...
+                             (mandatory-kwd mandatory-kwd-id) ...)))]
+                       [(this-parameter ...)
+                        (make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
+                                                  (car (generate-temporaries '(this)))
+                                                  (datum->syntax stx 'this #f)))])
            (with-syntax ([(dom-params ...)
                           #`(this-parameter ...
                              mandatory-regular-id ... 
@@ -841,47 +852,47 @@ v4 todo:
                                             (with-syntax ([param old-param])
                                               (syntax/loc stx
                                                 (syntax-parameterize
-                                                    ([param (make-this-transformer #'id)])
-                                                  body)))
+                                                 ([param (make-this-transformer #'id)])
+                                                 body)))
                                             #'body)])))])
                      (syntax-parameterize 
-                         ((making-a-method #f)) 
-                       (build-->d mtd? 
-                                  (list (λ (dom-params ...)
-                                          (parameterize-this this-parameter ... mandatory-doms)) ...)
-                                  (list (λ (dom-params ...) 
-                                          (parameterize-this this-parameter ... optional-doms)) ...)
-                                  (list (λ (dom-params ...) 
-                                          (parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
-                                  (list (λ (dom-params ...) 
-                                          (parameterize-this this-parameter ... optional-kwd-dom)) ...)
-                                  #,(if id/rest 
-                                        (with-syntax ([(id rst-ctc) id/rest])
-                                          #`(λ (dom-params ...)
-                                              (parameterize-this this-parameter ... rst-ctc)))
-                                        #f)
-                                  #,(if pre-cond
-                                        #`(λ (dom-params ...)
-                                            (parameterize-this this-parameter ... #,pre-cond))
-                                        #f)
-                                  #,(syntax-case #'rng-ctcs ()
-                                      [#f #f]
-                                      [(ctc ...) 
-                                       (if rng-underscores?
-                                           #'(box (list (λ (dom-params ...) 
-                                                          (parameterize-this this-parameter ... ctc)) ...))
-                                           #'(list (λ (rng-params ... dom-params ...)
-                                                     (parameterize-this this-parameter ... ctc)) ...))])
-                                  #,(if post-cond
-                                        #`(λ (rng-params ... dom-params ...)
-                                            (parameterize-this this-parameter ... #,post-cond))
-                                        #f)
-                                  '(mandatory-kwd ...)
-                                  '(optional-kwd ...)
-                                  (λ (f) 
-                                    #,(add-name-prop
-                                       (syntax-local-infer-name stx)
-                                       #`(λ args (apply f args)))))))))))))]))
+                      ((making-a-method #f)) 
+                      (build-->d mtd? 
+                                 (list (λ (dom-params ...)
+                                         (parameterize-this this-parameter ... mandatory-doms)) ...)
+                                 (list (λ (dom-params ...) 
+                                         (parameterize-this this-parameter ... optional-doms)) ...)
+                                 (list (λ (dom-params ...) 
+                                         (parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
+                                 (list (λ (dom-params ...) 
+                                         (parameterize-this this-parameter ... optional-kwd-dom)) ...)
+                                 #,(if id/rest 
+                                       (with-syntax ([(id rst-ctc) id/rest])
+                                         #`(λ (dom-params ...)
+                                             (parameterize-this this-parameter ... rst-ctc)))
+                                       #f)
+                                 #,(if pre-cond
+                                       #`(λ (dom-params ...)
+                                           (parameterize-this this-parameter ... #,pre-cond))
+                                       #f)
+                                 #,(syntax-case #'rng-ctcs ()
+                                     [#f #f]
+                                     [(ctc ...) 
+                                      (if rng-underscores?
+                                          #'(box (list (λ (dom-params ...) 
+                                                         (parameterize-this this-parameter ... ctc)) ...))
+                                          #'(list (λ (rng-params ... dom-params ...)
+                                                    (parameterize-this this-parameter ... ctc)) ...))])
+                                 #,(if post-cond
+                                       #`(λ (rng-params ... dom-params ...)
+                                           (parameterize-this this-parameter ... #,post-cond))
+                                       #f)
+                                 '(mandatory-kwd ...)
+                                 '(optional-kwd ...)
+                                 (λ (f) 
+                                   #,(add-name-prop
+                                      (syntax-local-infer-name stx)
+                                      #`(λ args (apply f args)))))))))))))]))
 
 (define ->d-tail-key (gensym '->d-tail-key))
 
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index 8ae6e79997..4fbd04e0cd 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -501,6 +501,10 @@ symbols, and that return a symbol.
 
 @defform*/subs[#:literals (any values)
 [(->d (mandatory-dependent-dom ...) 
+      dependent-rest
+      pre-cond
+      dep-range)
+ (->d (mandatory-dependent-dom ...) 
       (optional-dependent-dom ...) 
       dependent-rest
       pre-cond
@@ -525,8 +529,9 @@ expressions have been added in order to express contracts
 that are not naturally tied to a particular argument or
 result.
 
-The first two subforms of a @racket[->d] contract cover the
-mandatory and optional arguments. Following that is an
+The first subforms of a @racket[->d] contract covers the
+mandatory and the second (optional) subform covers the optional
+arguments. Following that is an
 optional rest-args contract, and an optional
 pre-condition. The @racket[dep-range] non-terminal covers
 the possible post-condition contracts. If it is
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 4c10b672d5..100f2d4995 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -180,6 +180,7 @@
   (test/no-error '(->d ([x integer?]) ([y integer?]) (values [a number?] [b boolean?])))
   (test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) (range boolean?)))
   (test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) #:rest rest any/c (range boolean?)))
+  (test/no-error '(->d ([x integer?] #:z [z integer?]) #:rest rest any/c (range boolean?)))
 
   (test/no-error '(unconstrained-domain-> number?))
   (test/no-error '(unconstrained-domain-> (flat-contract number?)))
@@ -1527,6 +1528,63 @@
                  'neg)
        (lambda () (set! x 2)))))
   
+
+  (test/spec-passed
+   '->d-optopt1
+   '((contract (->d ([x number?]) any)
+               (λ (x) x)
+               'pos 'neg)
+     1))
+  
+  (test/spec-passed
+   '->d-optopt2
+   '((contract (->d ([x number?]) #:rest rst any/c any)
+               (λ (x . y) x)
+               'pos 'neg)
+     1))
+
+  (test/spec-passed
+   '->d-optopt3
+   '((contract (->d ([x number?]) #:pre-cond #t any)
+               (λ (x) x)
+               'pos 'neg)
+     1))
+  
+  (test/spec-passed
+   '->d-optopt4
+   '((contract (->d ([x number?]) #:rest rst any/c #:pre-cond #t any)
+               (λ (x . y) x)
+               'pos 'neg)
+     1))
+  
+  (test/spec-passed
+   '->d-optopt5
+   '((contract (->d ([x number?]) #:rest rst any/c #:pre-cond #t [res any/c] #:post-cond #t)
+               (λ (x . y) x)
+               'pos 'neg)
+     1))
+  
+  (test/spec-passed
+   '->d-optopt6
+   '((contract (->d ([x number?]) #:rest rst any/c [res any/c] #:post-cond #t)
+               (λ (x . y) x)
+               'pos 'neg)
+     1))
+  
+  (test/spec-passed
+   '->d-optopt7
+   '((contract (->d ([x number?]) #:pre-cond #t [res any/c] #:post-cond #t)
+               (λ (x . y) x)
+               'pos 'neg)
+     1))
+  
+  (test/spec-passed
+   '->d-optopt8
+   '((contract (->d ([x number?]) [res any/c] #:post-cond #t)
+               (λ (x . y) x)
+               'pos 'neg)
+     1))
+
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;