#lang racket/base

(require "guts.rkt"
         "blame.rkt"
         "prop.rkt"
         "misc.rkt"
         racket/stxparam
         racket/private/performance-hint)
(require (for-syntax racket/base)
         (for-syntax "helpers.rkt")
         (for-syntax syntax/stx)
         (for-syntax syntax/name)
         (for-syntax "arr-util.rkt"))

(provide ->
         base->?
         ->*
         ->d
         base->-rngs/c
         base->-doms/c
         unconstrained-domain->
         the-unsupplied-arg
         unsupplied-arg?
         making-a-method
         method-contract?
         procedure-accepts-and-more?
         check-procedure
         check-procedure/more
         matches-arity-exactly?
         keywords-match
         bad-number-of-results
         (for-syntax check-tail-contract
                     make-this-parameters
                     parse-leftover->*)
         tail-contract-key
         tail-marks-match?
         get-blame-party-info
         values/drop
         arity-checking-wrapper
         unspecified-dom
         blame-add-range-context
         blame-add-nth-arg-context
         raise-no-keywords-arg
         raise-wrong-number-of-args-error)

(define-syntax-parameter making-a-method #f)
(define-syntax-parameter method-contract? #f)
(define-for-syntax (make-this-parameters id)
  (if (syntax-parameter-value #'making-a-method)
      (list id)
      null))

(define tail-contract-key (gensym 'tail-contract-key))

(define-for-syntax (check-tail-contract rng-ctcs blame-party-info neg-party rng-checkers call-gen)
  (unless (identifier? rng-ctcs)
    (raise-argument-error 'check-tail-contract
                          "identifier?"
                          0
                          rng-ctcs rng-checkers call-gen))
  #`(call-with-immediate-continuation-mark
     tail-contract-key
     (λ (m)
       (if (tail-marks-match? m #,rng-ctcs #,blame-party-info #,neg-party)
           #,(call-gen #'())
           #,(call-gen rng-checkers)))))

;; m : (or/c #f (cons/c neg-party (cons/c (list/c pos-party boolean?[blame-swapped?]) (listof ctc))))
;; rng-ctc : (or/c #f (listof ctc))
;; blame-party-info : (list/c pos-party boolean?[blame-swapped?])
;; neg-party : neg-party
(define (tail-marks-match? m rng-ctcs blame-party-info neg-party)
  (and m
       rng-ctcs
       (eq? (car m) neg-party)
       (let ([mark-blame-part-info (cadr m)])
         (and (eq? (car mark-blame-part-info) (car blame-party-info))
              (eq? (cadr mark-blame-part-info) (cadr blame-party-info))))
       (let loop ([m (cddr m)]
                  [rng-ctcs rng-ctcs])
         (cond
           [(null? m) (null? rng-ctcs)]
           [(null? rng-ctcs) (null? m)]
           [else
            (define m1 (car m))
            (define rng-ctc1 (car rng-ctcs))
            (cond
              [(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
              [(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))]
              [else #f])]))))

;; used as part of the information in the continuation mark
;; that records what is to be checked for a pending contract
(define (get-blame-party-info blame)
  (define swapped? (blame-swapped? blame))
  (list (if swapped? (blame-negative blame) (blame-positive blame))
        swapped?))

(define-syntax (unconstrained-domain-> stx)
  (syntax-case stx ()
    [(_ rngs ...)
     (with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
                   [(proj-x ...) (generate-temporaries #'(rngs ...))]
                   [(p-app-x ...) (generate-temporaries #'(rngs ...))]
                   [(res-x ...) (generate-temporaries #'(rngs ...))])
       #`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
           (let ([rngs-list (list rngs-x ...)]
                 [proj-x (get/build-late-neg-projection rngs-x)] ...)
             (define (projection wrapper get-ctc)
               (λ (orig-blame)
                 (define blame-party-info (get-blame-party-info orig-blame))
                 (define ctc (get-ctc))
                 (let ([rng-blame (blame-add-range-context orig-blame)])
                   (let* ([p-app-x (proj-x rng-blame)] ...)
                     (λ (val neg-party)
                       (check-is-a-procedure orig-blame neg-party val)
                       (define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...))
                       (wrapper
                        val
                        (make-keyword-procedure
                         (λ (kwds kwd-vals . args)
                           (with-contract-continuation-mark
                            (cons orig-blame neg-party)
                            #,(check-tail-contract
                               #'rngs-list
                               #'blame-party-info
                               #'neg-party
                               (list #'res-checker)
                               (λ (s) #`(apply values #,@s kwd-vals args)))))
                         (λ args
                           (with-contract-continuation-mark
                            (cons orig-blame neg-party)
                            #,(check-tail-contract
                               #'rngs-list
                               #'blame-party-info
                               #'neg-party
                               (list #'res-checker)
                               (λ (s) #`(apply values #,@s args))))))
                        impersonator-prop:contracted ctc
                        impersonator-prop:application-mark
                        (cons tail-contract-key (list neg-party blame-party-info rngs-x ...))))))))
             (make-unconstrained-domain-> (list rngs-x ...) 
                                          projection))))]))

(define (check-is-a-procedure orig-blame neg-party val)
  (unless (procedure? val)
    (raise-blame-error orig-blame #:missing-party neg-party
                       val
                       '(expected: "a procedure" given: "~v")
                       val)))

(define (make-unconstrained-domain-> ctcs late-neg-projection)
  (define name
    (apply build-compound-type-name 'unconstrained-domain->
           (map contract-name ctcs)))
  (define ctc
    (if (andmap chaperone-contract? ctcs)
        (make-chaperone-contract
         #:name name
         #:late-neg-projection (late-neg-projection chaperone-procedure (λ () ctc))
         #:first-order procedure?)
        (make-contract
         #:name name
         #:late-neg-projection (late-neg-projection impersonate-procedure (λ () ctc))
         #:first-order procedure?)))
  ctc)

;              
;              
;              
;         ;    
;          ;   
;           ;  
;   ;;;;;;;;;; 
;           ;  
;          ;   
;         ;    
;              
;              
;              
;              

;; matches-arity-exactly? : procedure number (or/c number #f) (listof keyword?) (listof keyword?) -> boolean
(define (matches-arity-exactly? val min-arity max-arity contract-req-kwds contract-opt-kwds)
  (define proc-arity (procedure-arity val)) 
  (and (let-values ([(vr va) (procedure-keywords val)])
         (and va (equal? vr contract-req-kwds) 
	         (keywords-match? va contract-req-kwds contract-opt-kwds)))
       (cond
         [(number? proc-arity) (and (number? max-arity)
                                    (= min-arity max-arity)
                                    (= proc-arity min-arity))]
         [(arity-at-least? proc-arity) (and (not max-arity)
                                            (= (arity-at-least-value proc-arity)
                                               min-arity))]
         [else
          (let loop ([arity proc-arity]
                     [i min-arity])
            (cond
              [(null? arity) 
               (= i (+ max-arity 1))]
              [else
               (let ([fst (car arity)])
                 (if (arity-at-least? fst)
                     (and (number? max-arity)
                          (= (arity-at-least-value fst)
                             max-arity))
                     (and (= i fst)
                          (loop (cdr arity)
                                (+ i 1)))))]))])))

(define (keywords-match? accepted-keywords contract-req-kwds contract-opt-kwds)
  (let loop ([accepted accepted-keywords]
             [req-kwds contract-req-kwds]
             [opt-kwds contract-opt-kwds])
    (cond
      [(null? accepted) (and (null? opt-kwds) (null? req-kwds))]
      [else
       (let ([kwd (car accepted)])
         (cond
          [(and (pair? req-kwds) (eq? (car req-kwds) kwd))
           (loop (cdr accepted) (cdr req-kwds) opt-kwds)]
          [(and (pair? opt-kwds) (eq? (car opt-kwds) kwd))
           (loop (cdr accepted) req-kwds (cdr opt-kwds))]
          [else #f]))])))

(define-for-syntax (create-chaperone blame neg-party blame-party-info val pre post this-args
                                     doms opt-doms dom-rest req-kwds opt-kwds
                                     rngs rng-ctc-id)
  (with-syntax ([blame blame]
                [neg-party neg-party]
                [val val])
    (with-syntax ([(pre ...) 
                   (if pre
                       (list #`(unless #,pre
                                 (raise-blame-error
                                  (blame-swap blame) #:missing-party neg-party
                                  val "#:pre condition")))
                       null)]
                  [(post ...)
                   (if post
                       (list #`(unless #,post
                                 (raise-blame-error
                                  blame #:missing-party neg-party
                                  val "#:post condition")))
                       null)])
      (with-syntax ([(this-param ...) this-args]
                    [(dom-ctc ...) doms]
                    [(dom-x ...) (generate-temporaries doms)]
                    [(opt-dom-ctc ...) opt-doms]
                    [(opt-dom-x ...) (generate-temporaries opt-doms)]
                    [(rest-ctc (rest-x)) (list dom-rest (generate-temporaries '(rest)))]
                    [(req-kwd ...) (map car req-kwds)]
                    [(req-kwd-ctc ...) (map cadr req-kwds)]
                    [(req-kwd-x ...) (generate-temporaries (map car req-kwds))]
                    [(opt-kwd ...) (map car opt-kwds)]
                    [(opt-kwd-ctc ...) (map cadr opt-kwds)]
                    [(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))]
                    [(rng-ctc ...) (if rngs rngs '())]
                    [(rng-x ...) (if rngs (generate-temporaries rngs) '())])
        (with-syntax ([(rng-checker-name ...)
                       (if rngs
                           (list (gen-id 'rng-checker))
                           null)]
                      [(rng-checker ...)
                       (if rngs
                           (list
                            (with-syntax ([rng-len (length rngs)])
                              (with-syntax ([rng-results
                                             (if (and (pair? rngs) (null? (cdr rngs)))
                                                 (with-syntax ([proj (car (syntax->list #'(rng-ctc ...)))]
                                                               [name (car (syntax->list #'(rng-x ...)))])
                                                   #'(proj name neg-party))
                                                 #'(values/drop (rng-ctc rng-x neg-party) ...))])
                                #'(case-lambda
                                    [(rng-x ...)
                                     (with-contract-continuation-mark
                                      (cons blame neg-party)
                                      (let ()
                                        post ...
                                        rng-results))]
                                    [args
                                     (bad-number-of-results blame val rng-len args)]))))
                           null)])
          (let* ([min-method-arity (length doms)]
                 [max-method-arity (+ min-method-arity (length opt-doms))]
                 [min-arity (+ (length this-args) min-method-arity)]
                 [max-arity (+ min-arity (length opt-doms))]
                 [req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)]
                 [opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)]
                 [need-apply-values? (or dom-rest (not (null? opt-doms)))]
                 [no-rng-checking? (not rngs)])
            (with-syntax ([basic-params
                           (cond
                             [dom-rest
                              #'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ... . rest-x)]
                             [else
                              #'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ...)])]
                          [opt+rest-uses
                           (for/fold ([i (if dom-rest #'(rest-ctc rest-x neg-party) #'null)])
                                     ([o (in-list (reverse
                                                   (syntax->list
                                                    #'((opt-dom-ctc opt-dom-x) ...))))])
                             (let* ([l (syntax->list o)]
                                    [c (car l)]
                                    [x (cadr l)])
                               #`(let ([r #,i])
                                   (if (eq? unspecified-dom #,x) r (cons (#,c #,x neg-party) r)))))]
                          [(kwd-param ...)
                           (apply append
                                  (map list
                                       (syntax->list #'(req-kwd ... opt-kwd ...))
                                       (syntax->list #'(req-kwd-x ... [opt-kwd-x unspecified-dom] ...))))]
                          [kwd-stx
                           (let* ([req-stxs
                                   (map (λ (s) (λ (r) #`(cons #,s #,r)))
                                        (syntax->list #'((req-kwd-ctc req-kwd-x neg-party) ...)))]
                                  [opt-stxs 
                                   (map (λ (x c) (λ (r) #`(let ([r #,r])
                                                            (if (eq? unspecified-dom #,x)
                                                                r
                                                                (cons (#,c #,x neg-party) r)))))
                                        (syntax->list #'(opt-kwd-x ...))
                                        (syntax->list #'(opt-kwd-ctc ...)))]
                                  [reqs (map cons req-keywords req-stxs)]
                                  [opts (map cons opt-keywords opt-stxs)]
                                  [all-together-now (append reqs opts)]
                                  [put-in-reverse (sort all-together-now (λ (k1 k2) (keyword<? k2 k1)) #:key car)])
                             (for/fold ([s #'null])
                               ([tx (in-list (map cdr put-in-reverse))])
                               (tx s)))])
              (with-syntax ([kwd-lam-params
                             (if dom-rest
                                 #'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ... kwd-param ... . rest-x)
                                 #'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ... kwd-param ...))]
                            [basic-return
                             (let ([inner-stx-gen
                                    (if need-apply-values?
                                        (λ (s) #`(apply values #,@s this-param ...
                                                        (dom-ctc dom-x neg-party) ... opt+rest-uses))
                                        (λ (s) #`(values/drop #,@s this-param ...
                                                              (dom-ctc dom-x neg-party) ...)))])
                               (if no-rng-checking?
                                   (inner-stx-gen #'())
                                   (check-tail-contract rng-ctc-id
                                                        blame-party-info
                                                        #'neg-party
                                                        #'(rng-checker-name ...)
                                                        inner-stx-gen)))]
                            [kwd-return
                             (let* ([inner-stx-gen
                                     (if need-apply-values?
                                         (λ (s k) #`(apply values #,@s #,@k this-param ...
                                                           (dom-ctc dom-x neg-party) ...
                                                           opt+rest-uses))
                                         (λ (s k) #`(values/drop #,@s #,@k this-param ...
                                                                 (dom-ctc dom-x neg-party) ...)))]
                                    [outer-stx-gen
                                     (if (null? req-keywords)
                                         (λ (s)
                                           #`(if (null? kwd-results)
                                                 #,(inner-stx-gen s #'())
                                                 #,(inner-stx-gen s #'(kwd-results))))
                                         (λ (s)
                                           (inner-stx-gen s #'(kwd-results))))])
                               #`(let ([kwd-results kwd-stx])
                                   #,(if no-rng-checking?
                                         (outer-stx-gen #'())
                                         (check-tail-contract rng-ctc-id
                                                              blame-party-info
                                                              #'neg-party
                                                              #'(rng-checker-name ...)
                                                              outer-stx-gen))))])
                (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
                              [basic-lambda #'(λ basic-params
                                                ;; Arrow contract domain checking is instrumented
                                                ;; both here, and in `arity-checking-wrapper'.
                                                ;; We need to instrument here, because sometimes
                                                ;; a-c-w doesn't wrap, and just returns us.
                                                ;; We need to instrument in a-c-w to count arity
                                                ;; checking time.
                                                ;; Overhead of double-wrapping has not been
                                                ;; noticeable in my measurements so far.
                                                ;;  - stamourv
                                                (with-contract-continuation-mark
                                                 (cons blame neg-party)
                                                 (let ()
                                                   pre ... basic-return)))]
                              [kwd-lambda-name (gen-id 'kwd-lambda)]
                              [kwd-lambda #`(λ kwd-lam-params
                                              (with-contract-continuation-mark
                                               (cons blame neg-party)
                                               (let ()
                                                 pre ... kwd-return)))])
                  (with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))])
                    (cond
                      [(and (null? req-keywords) (null? opt-keywords))
                       #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
                           (let ([basic-lambda-name basic-lambda])
                             (arity-checking-wrapper val blame neg-party
                                                     basic-lambda-name
                                                     void
                                                     #,min-method-arity
                                                     #,max-method-arity
                                                     #,min-arity
                                                     #,(if dom-rest #f max-arity)
                                                     '(req-kwd ...)
                                                     '(opt-kwd ...))))]
                      [(pair? req-keywords)
                       #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
                           (let ([kwd-lambda-name kwd-lambda])
                             (arity-checking-wrapper val blame neg-party
                                                     void
                                                     kwd-lambda-name
                                                     #,min-method-arity
                                                     #,max-method-arity
                                                     #,min-arity
                                                     #,(if dom-rest #f max-arity)
                                                     '(req-kwd ...)
                                                     '(opt-kwd ...))))]
                      [else
                       #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
                           (let ([basic-lambda-name basic-lambda]
                                 [kwd-lambda-name kwd-lambda])
                             (arity-checking-wrapper val blame neg-party
                                                     basic-lambda-name
                                                     kwd-lambda-name
                                                     #,min-method-arity
                                                     #,max-method-arity
                                                     #,min-arity
                                                     #,(if dom-rest #f max-arity)
                                                     '(req-kwd ...)
                                                     '(opt-kwd ...))))])))))))))))

;; should we pass both the basic-lambda and the kwd-lambda?
(define (arity-checking-wrapper val blame neg-party basic-lambda kwd-lambda
                                min-method-arity max-method-arity min-arity max-arity 
                                req-kwd opt-kwd)
  ;; should not build this unless we are in the 'else' case (and maybe not at all)
  (cond
    [(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
     (if (and (null? req-kwd) (null? opt-kwd)) 
         basic-lambda
         kwd-lambda)]
    [else
     (define-values (vr va) (procedure-keywords val))
     (define all-kwds (append req-kwd opt-kwd))
     (define (valid-number-of-args? args)
       (if max-arity
           (<= min-arity (length args) max-arity)
           (<= min-arity (length args))))
     (define kwd-checker
       (if (and (null? req-kwd) (null? opt-kwd))
           (λ (kwds kwd-args . args)
             (raise-no-keywords-arg blame #:missing-party neg-party val kwds))
           (λ (kwds kwd-args . args)
             (with-contract-continuation-mark
              (cons blame neg-party)
              (let ()
             (define args-len (length args))
             (unless (valid-number-of-args? args)
               (raise-wrong-number-of-args-error
                blame #:missing-party neg-party val
                args-len max-arity min-method-arity max-method-arity))
             
             ;; these two for loops are doing O(n^2) work that could be linear 
             ;; (since the keyword lists are sorted)
             (for ([req-kwd (in-list req-kwd)])
               (unless (memq req-kwd kwds)
                 (raise-blame-error (blame-swap blame) #:missing-party neg-party
                                    val
                                    '(expected "keyword argument ~a")
                                    req-kwd)))
             (for ([k (in-list kwds)])
               (unless (memq k all-kwds)
                 (raise-blame-error (blame-swap blame) #:missing-party neg-party val
                                    '(received: "unexpected keyword argument ~a")
                                    k)))
             (keyword-apply kwd-lambda kwds kwd-args args))))))
     (define basic-checker-name 
       (if (null? req-kwd)
           (λ args
             (with-contract-continuation-mark
              (cons blame neg-party)
              (let ()
             (unless (valid-number-of-args? args)
               (define args-len (length args))
               (raise-wrong-number-of-args-error
                blame #:missing-party neg-party val
                args-len max-arity min-method-arity max-method-arity))
             (apply basic-lambda args))))
           (λ args
             (raise-blame-error (blame-swap blame) #:missing-party neg-party val
                                "expected required keyword ~a"
                                (car req-kwd)))))
     (if (or (not va) (pair? vr) (pair? va))
         (make-keyword-procedure kwd-checker basic-checker-name)
         basic-checker-name)]))

(define (raise-wrong-number-of-args-error
         blame #:missing-party [missing-party #f] val
         args-len max-arity min-method-arity max-method-arity)
  (define arity-string 
    (if max-arity
        (cond
          [(= min-method-arity max-method-arity)
           (format "~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))]
          [(= (+ min-method-arity 1) max-method-arity) 
           (format "~a or ~a non-keyword arguments" min-method-arity max-method-arity)]
          [else
           (format "~a to ~a non-keyword arguments" min-method-arity max-method-arity)])
        (format "at least ~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))))
  (raise-blame-error (blame-swap blame) val
                     #:missing-party missing-party
                     '(received: "~a argument~a" expected: "~a")
                     args-len (if (= args-len 1) "" "s") arity-string))

(define (raise-no-keywords-arg blame #:missing-party [missing-party #f] val given-kwds)
  (raise-blame-error (blame-swap blame) val
                     #:missing-party missing-party
                     (list 'expected:
                           "no keywords"
                           'given:
                           (apply
                            string-append
                            (let loop ([kwds given-kwds])
                              (cond
                                [(null? kwds) '()]
                                [(null? (cdr kwds))
                                 (list "#:" (keyword->string (car kwds)))]
                                [else
                                 (list* "#:"
                                        (keyword->string (car kwds))
                                        " "
                                        (loop (cdr kwds)))]))))))

;; pre : (or/c #f (-> any)) -- checks the pre-condition, if there is one.
;; post : (or/c #f (-> any)) -- checks the post-condition, if there is one.
;; doms : (listof contract)
;; optional-doms/c : (listof contract)
;; dom-rest : (or/c false/c contract)
;; mandatory-kwds/c : (listof contract)
;; mandatory-kwds : (listof keyword) -- must be sorted by keyword<
;; optional-kwds/c : (listof contract)
;; optional-kwds : (listof keyword) -- must be sorted by keyword<
;; rngs : (listof contract) -- may be ignored by the wrapper function in the case of any
;; rng-any? : boolean
;; mtd? : contract is for a method (implicit this in first position)
;; mctc? : contract was formed with ->m or ->*m (so print out same way)
;; func : the wrapper function maker. It accepts a procedure for
;;        checking the first-order properties and the contracts
;;        and it produces a wrapper-making function.
(define-struct base-> (pre post
                       doms/c optional-doms/c dom-rest/c
                       mandatory-kwds/c mandatory-kwds
                       optional-kwds/c optional-kwds
                       rngs/c rng-any?
                       mtd? mctc?
                       func))

(define ((late-neg-->-proj wrapper) ctc)
  (let* ([doms-proj (map get/build-late-neg-projection
                         (if (base->-dom-rest/c ctc)
                             (append (base->-doms/c ctc) (list (base->-dom-rest/c ctc)))
                             (base->-doms/c ctc)))]
         [doms-optional-proj (map get/build-late-neg-projection (base->-optional-doms/c ctc))]
         [rngs-ctc (base->-rngs/c ctc)]
         [rngs-proj (map get/build-late-neg-projection rngs-ctc)]
         [mandatory-kwds-proj (map get/build-late-neg-projection (base->-mandatory-kwds/c ctc))]
         [optional-kwds-proj (map get/build-late-neg-projection (base->-optional-kwds/c ctc))]
         [mandatory-keywords (base->-mandatory-kwds ctc)]
         [optional-keywords (base->-optional-kwds ctc)]
         [func (base->-func ctc)]
         [dom-length (length (base->-doms/c ctc))]
         [optionals-length (length (base->-optional-doms/c ctc))]
         [has-rest? (and (base->-dom-rest/c ctc) #t)]
         [pre (base->-pre ctc)]
         [post (base->-post ctc)]
         [mtd? (base->-mtd? ctc)])
    (λ (orig-blame)
      (define rng-blame (blame-add-range-context orig-blame))
      (define partial-doms 
        (for/list ([dom (in-list doms-proj)]
                   [n (in-naturals 1)])
          (dom (blame-add-context orig-blame
                                  (if (and has-rest?
                                           (n . > . dom-length))
                                      "the rest argument of"
                                      (format "the ~a argument of"
                                              (n->th n)))
                                  #:swap? #t))))
      (define partial-optional-doms 
        (for/list ([dom (in-list doms-optional-proj)]
                   [n (in-naturals (+ 1 (length doms-proj)))])
          (dom (blame-add-context orig-blame
                                  (format "the ~a argument of"
                                          (n->th n))
                                  #:swap? #t))))
      (define partial-ranges (map (λ (rng) (rng rng-blame)) rngs-proj))
      (define partial-mandatory-kwds 
        (for/list ([kwd-proj (in-list mandatory-kwds-proj)]
                   [kwd (in-list mandatory-keywords)])
          (kwd-proj (blame-add-context orig-blame 
                                       (format "the ~a argument of" kwd)
                                       #:swap? #t))))
      (define partial-optional-kwds 
        (for/list ([kwd-proj (in-list optional-kwds-proj)]
                   [kwd (in-list optional-keywords)])
          (kwd-proj (blame-add-context orig-blame
                                       (format "the ~a argument of" kwd)
                                       #:swap? #t))))
      (define the-args (cons rngs-ctc
                             (append partial-doms partial-optional-doms
                                     partial-mandatory-kwds partial-optional-kwds
                                     partial-ranges)))
      (define blame-party-info (get-blame-party-info orig-blame))
      (λ (val neg-party)
        (if has-rest?
            (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords
                                  orig-blame neg-party)
            (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords
                             orig-blame neg-party))
        (define chap/imp-func (apply func orig-blame neg-party blame-party-info val the-args))
        (if post
            (wrapper
             val
             chap/imp-func
             impersonator-prop:contracted ctc)
            (wrapper
             val
             chap/imp-func
             impersonator-prop:contracted ctc
             impersonator-prop:application-mark
             (cons tail-contract-key (list* neg-party blame-party-info rngs-ctc))))))))

(define (->-name ctc)
  (single-arrow-name-maker 
   (base->-doms/c ctc)
   (base->-optional-doms/c ctc)
   (base->-dom-rest/c ctc)
   (base->-mandatory-kwds/c ctc)
   (base->-mandatory-kwds ctc)
   (base->-optional-kwds/c ctc)
   (base->-optional-kwds ctc)
   (base->-rng-any? ctc)
   (base->-rngs/c ctc)
   (base->-pre ctc)
   (base->-post ctc)
   (base->-mctc? ctc)))

(define (->-first-order ctc)
  (λ (x)
    (define l (+ (length (base->-doms/c ctc))
                 (if (base->-mctc? ctc) 1 0)))
    (and (procedure? x) 
         (if (base->-dom-rest/c ctc)
             (procedure-accepts-and-more? x l)
             (procedure-arity-includes? x l #t))
         (keywords-match (base->-mandatory-kwds ctc) (base->-optional-kwds ctc) x)
         #t)))

(define (->-stronger? this that)
  (and (base->? that)
       (= (length (base->-doms/c that)) (length (base->-doms/c this)))
       (andmap contract-struct-stronger? (base->-doms/c that) (base->-doms/c this))
       
       (equal? (base->-mandatory-kwds this) (base->-mandatory-kwds that))
       (andmap contract-struct-stronger? (base->-mandatory-kwds/c that) (base->-mandatory-kwds/c this))
       
       (equal? (base->-optional-kwds this) (base->-optional-kwds that))
       (andmap contract-struct-stronger? (base->-optional-kwds/c that) (base->-optional-kwds/c this))
       
       (= (length (base->-rngs/c that)) (length (base->-rngs/c this)))
       (andmap contract-struct-stronger? (base->-rngs/c this) (base->-rngs/c that))
       
       ;; these procs might be based on state; only 
       ;; allow stronger to be true when #:pre and
       ;; #:post aren't specified at all
       (not (base->-pre this))
       (not (base->-pre that))
       (not (base->-post this))
       (not (base->-post that))))

(define-struct (chaperone-> base->) ()
  #:property prop:custom-write custom-write-property-proc
  #:property prop:chaperone-contract
  (build-chaperone-contract-property
   #:late-neg-projection (late-neg-->-proj chaperone-procedure)
   #:name ->-name
   #:first-order ->-first-order
   #:stronger ->-stronger?))

(define-struct (impersonator-> base->) ()
  #:property prop:custom-write custom-write-property-proc
  #:property prop:contract
  (build-contract-property
   #:late-neg-projection (late-neg-->-proj impersonate-procedure)
   #:name ->-name
   #:first-order ->-first-order
   #:stronger ->-stronger?))

(define (build--> name
                  pre post
                  doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f 
                  mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
                  rngs/c-or-p
                  rng-any? mtd? ->m-ctc? func)
  (let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
    (let ([doms/c (map cc doms/c-or-p)]
          [opt-doms/c (map cc optional-doms/c-or-p)]
          [rest/c (and doms-rest/c-or-p-or-f (cc doms-rest/c-or-p-or-f))]
          [kwds/c (map cc mandatory-kwds/c-or-p)]
          [opt-kwds/c (map cc optional-kwds/c-or-p)]
          [rngs/c (map cc rngs/c-or-p)])
      (if (and (andmap chaperone-contract? doms/c)
               (andmap chaperone-contract? opt-doms/c)
               (or (not rest/c) (chaperone-contract? rest/c))
               (andmap chaperone-contract? kwds/c)
               (andmap chaperone-contract? opt-kwds/c)
               (or rng-any? (andmap chaperone-contract? rngs/c)))
          (make-chaperone-> pre post doms/c opt-doms/c rest/c
                            kwds/c mandatory-kwds opt-kwds/c optional-kwds
                            rngs/c rng-any? mtd? ->m-ctc? func)
          (make-impersonator-> pre post doms/c opt-doms/c rest/c
                               kwds/c mandatory-kwds opt-kwds/c optional-kwds
                               rngs/c rng-any? mtd? ->m-ctc? func)))))

(define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs pre post ->m-ctc?)
  (cond
    [(or doms-rest 
         (not (null? optional-kwds))
         (not (null? optional-doms/c))
         pre post)
     (let ([name (if ->m-ctc? '->*m '->*)]
           [range
            (cond
              [rng-any? 'any]
              [(and (pair? rngs)
                    (null? (cdr rngs)))
               (car rngs)]
              [else (apply build-compound-type-name 'values rngs)])])
       (apply
        build-compound-type-name 
        name
        (apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c))))
        (append (let ([opts
                       (apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c))))])
                  (if (null? opts)
                      '()
                      (list opts)))
                (if doms-rest
                    (list '#:rest doms-rest)
                    (list))
                (if pre 
                    (list '#:pre '...)
                    (list))
                (list range)
                (if post
                    (list '#:post '...)
                    (list)))))]
    [else
     (let ([name (if ->m-ctc? '->m '->)]
           [rng-name
            (cond
              [rng-any? 'any]
              [(null? rngs) '(values)]
              [(null? (cdr rngs)) (car rngs)]
              [else (apply build-compound-type-name 'values rngs)])])
       (apply build-compound-type-name 
              name
              (append doms/c
                      (apply append (map list kwds kwds/c))
                      (list rng-name))))]))

(define-for-syntax (->-helper stx)
  (syntax-case stx ()
    [(-> raw-doms ... last-one)
     (with-syntax ([((doms ...) ((dom-kwd dom-kwd-ctc) ...)) (split-doms stx '-> #'(raw-doms ...))])
       (with-syntax ([(dom-kwd-arg ...) (generate-temporaries (syntax (dom-kwd ...)))]
                     [(dom-kwd-ctc-id ...) (generate-temporaries (syntax (dom-kwd ...)))])
         (with-syntax ([(keyword-call/ctc ...) (apply append (map syntax->list (syntax->list #'((dom-kwd (dom-kwd-ctc-id dom-kwd-arg)) ...))))]
                       [(keyword-formal-parameters ...) (apply append (map syntax->list (syntax->list #'((dom-kwd dom-kwd-arg) ...))))]
                       [(args ...) (generate-temporaries (syntax (doms ...)))]
                       [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
                       [(this-parameter ...)
                        (make-this-parameters (car (generate-temporaries '(this))))])
           (syntax-case* #'last-one (-> any values) module-or-top-identifier=?
             [any
              (with-syntax ([(ignored) (generate-temporaries (syntax (rng)))])
                (values (syntax (this-parameter ...))
                        (syntax (dom-ctc ...))
                        (syntax (ignored))
                        (syntax (dom-kwd-ctc-id ...))
                        (syntax (doms ...))
                        (syntax (any/c))
                        (syntax (dom-kwd-ctc ...))
                        (syntax (dom-kwd ...))
                        (syntax (this-parameter ... args ... keyword-formal-parameters ...))
                        #t))]
             [(values rngs ...)
              (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
                            [(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
                (values (syntax (this-parameter ...))
                        (syntax (dom-ctc ...))
                        (syntax (rng-ctc ...))
                        (syntax (dom-kwd-ctc-id ...))
                        (syntax (doms ...))
                        (syntax (rngs ...))
                        (syntax (dom-kwd-ctc ...))
                        (syntax (dom-kwd ...))
                        (syntax (this-parameter ... args ... keyword-formal-parameters ...))
                        #f))]
             [rng
              (with-syntax ([(rng-ctc) (generate-temporaries (syntax (rng)))])
                (values (syntax (this-parameter ...))
                        (syntax (dom-ctc ...))
                        (syntax (rng-ctc))
                        (syntax (dom-kwd-ctc-id ...))
                        (syntax (doms ...))
                        (syntax (rng))
                        (syntax (dom-kwd-ctc ...))
                        (syntax (dom-kwd ...))
                        (syntax (this-parameter ... args ... keyword-formal-parameters ...))
                        #f))]))))]))

(define-for-syntax (maybe-a-method/name stx)
  (if (syntax-parameter-value #'making-a-method)
      (syntax-property stx 'method-arity-error #t)
      stx))

;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define-for-syntax (->/proc/main stx)
  (let-values ([(this-params dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds args use-any?) (->-helper stx)]
               [(this->) (gensym 'this->)])
    (with-syntax ([(this-params ...) this-params]
                  [(dom-names ...) dom-names]
                  [(rng-names ...) rng-names]
                  [(kwd-names ...) kwd-names]
                  [(dom-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->)) 
                                       (syntax->list dom-ctcs))]
                  [(rng-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:positive-position this->))
                                       (syntax->list rng-ctcs))]
                  [(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->))
                                       (syntax->list kwd-ctcs))]
                  [(kwds ...) kwds]
                  [(rng-ctc-x) (generate-temporaries '(rng-ctc-x))]
                  [use-any? use-any?])
      (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
                    [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
                    [outer-lambda
                     #`(lambda (blame neg-party blame-party-info val rng-ctc-x
                                      dom-names ... kwd-names ... rng-names ...)
                         #,(create-chaperone 
                            #'blame #'neg-party #'blame-party-info #'val #f #f
                            (syntax->list #'(this-params ...))
                            (syntax->list #'(dom-names ...)) null #f
                            (map list (syntax->list #'(kwds ...))
                                 (syntax->list #'(kwd-names ...)))
                            null
                            (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))
                            #'rng-ctc-x))])
        (syntax-property
         (syntax/loc stx
          (build--> '->
                    #f #f
                    (list dom-ctcs ...) '() #f
                    (list kwd-ctcs ...) '(kwds ...) '() '()
                    (list rng-ctcs ...) use-any?
                    mtd? ->m-ctc?
                    outer-lambda))
         'racket/contract:contract
         (vector this->
                 ;; the -> in the original input to this guy
                 (list (car (syntax-e stx)))
                 '()))))))


;                     
;                     
;                     
;         ;       ;   
;          ;      ;   
;           ;   ;;;;; 
;   ;;;;;;;;;;   ;;   
;           ;    ; ;  
;          ;          
;         ;           
;                     
;                     
;                     
;                     


(define unspecified-dom (gensym 'unspecified-keyword))

;; check-duplicate-kwds : syntax (listof syntax[keyword]) -> void
(define-for-syntax (check-duplicate-kwds stx kwds)
  (let loop ([kwds kwds])
    (unless (null? kwds)
      (when (member (syntax-e (car kwds)) (map syntax-e (cdr kwds)))
        (raise-syntax-error #f "duplicate keyword" stx (car kwds))))))

;; -> (values raw-optional-doms rest-ctc pre rng-ctc post)
;; rest-ctc (or/c #f syntax) -- #f means no rest contract, syntax is the contract
;; rng-ctc (or/c #f syntax) -- #f means `any', syntax is a sequence of result values
(define-for-syntax (parse-leftover->* stx leftover)
  (let*-values ([(raw-optional-doms leftover)
                 (syntax-case leftover ()
                   [(kwd . rst)
                    (keyword? (syntax-e #'kwd))
                    (values #'() leftover)]
                   [(rng #:post . rst)
                    (values #'() leftover)]
                   [(rng #:post/desc . rst)
                    (values #'() leftover)]
                   [(rng)
                    (values #'() leftover)]
                   [((raw-optional-dom ...) . leftover)
                    (values #'(raw-optional-dom ...) #'leftover)]
                   [_ 
                    (values #'() leftover)])]
                [(rst leftover)
                 (syntax-case leftover ()
                   [(#:rest rest-expr . leftover)
                    (values #'rest-expr #'leftover)]
                   [_ (values #f leftover)])]
                [(pre pre/desc leftover)
                 (syntax-case leftover ()
                   [(#:pre pre-expr . leftover)
                    (values #'pre-expr #f #'leftover)]
                   [(#:pre/desc pre-expr . leftover)
                    (values #f #'pre-expr #'leftover)]
                   [_ (values #f #f leftover)])]
                [(rng leftover)
                 (syntax-case leftover (any values)
                   [(any) (values #f #'())]
                   [(any . more) (raise-syntax-error #f "expected nothing to follow any" stx #'any)]
                   [((values ctc ...) . leftover)
                    (values #'(ctc ...) #'leftover)]
                   [(rng . leftover)
                    (begin
                      (when (keyword? (syntax-e #'rng))
                        (raise-syntax-error #f "expected a range contract" stx #'rng))
                      (values #'(rng) #'leftover))]
                   [_
                    (raise-syntax-error #f "expected a range contract" stx leftover)])]
                [(post post/desc leftover)
                 (syntax-case leftover ()
                   [(#:post post-expr . leftover)
                    (values #'post-expr #f #'leftover)]
                   [(#:post/desc post-expr . leftover)
                    (values #f #'post-expr #'leftover)]
                   [else
                    (values #f #f leftover)])])
    (syntax-case leftover ()
      [() (values raw-optional-doms rst pre pre/desc rng post post/desc)]
      [x (raise-syntax-error #f "expected the end of the contract" stx #'x)])))

;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define-for-syntax (->*/proc/main stx)
  (syntax-case* stx (->* any) module-or-top-identifier=?
    [(->* (raw-mandatory-dom ...) . rst)
     (let-values ([(raw-optional-doms rest-ctc raw-pre pre/desc rng-ctc raw-post post/desc)
                   (parse-leftover->* stx #'rst)])
       (define pre (cond
                     [raw-pre raw-pre]
                     [pre/desc
                      #`(convert-pre-post/desc-to-boolean #t #,pre/desc)]
                     [else #f]))
       (define post (cond
                      [raw-post raw-post]
                      [post/desc #`(convert-pre-post/desc-to-boolean #f #,post/desc)]
                      [else #f]))
       (with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...))
                      (split-doms stx '->* #'(raw-mandatory-dom ...))]
                     [((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...))
                      (split-doms stx '->* raw-optional-doms)])
         ;(check-duplicate-kwds stx (syntax->list #'(mandatory-dom-kwd ... optional-dom-kwd ...)))
         (with-syntax ([(mandatory-dom-proj ...) (generate-temporaries #'(mandatory-dom ...))]
                       [(mandatory-dom-arg ...) (generate-temporaries #'(mandatory-dom ...))]
                       [(mandatory-dom-kwd-proj ...) (generate-temporaries #'(mandatory-dom-kwd ...))]
                       [(mandatory-dom-kwd-arg ...) (generate-temporaries #'(mandatory-dom-kwd ...))]
                       
                       [(optional-dom-proj ...) (generate-temporaries #'(optional-dom ...))]
                       [(optional-dom-arg ...) (generate-temporaries #'(optional-dom ...))]
                       [(optional-dom-kwd-proj ...) (generate-temporaries #'(optional-dom-kwd ...))]
                       [(optional-dom-kwd-arg ...) (generate-temporaries #'(optional-dom-kwd ...))])
           (with-syntax ([(mandatory-dom-kwd/var-seq ...) (apply append 
                                                                 (map list
                                                                      (syntax->list #'(mandatory-dom-kwd ...)) 
                                                                      (syntax->list #'(mandatory-dom-kwd-arg ...))))]
                         [(optional-dom-kwd/var-seq ...) (apply append 
                                                                (map list 
                                                                     (syntax->list #'(optional-dom-kwd ...)) 
                                                                     (syntax->list #'([optional-dom-kwd-arg unspecified-dom] ...))))]
                         [(mandatory-dom-kwd-proj-apps ...) (apply append 
                                                                   (map list
                                                                        (syntax->list #'(mandatory-dom-kwd ...)) 
                                                                        (syntax->list #'((mandatory-dom-kwd-proj mandatory-dom-kwd-arg) ...))))]
                         [((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...) 
                          (sort-keywords stx (syntax->list
                                              #'((mandatory-dom-kwd mandatory-dom-kwd-arg mandatory-dom-kwd-proj) ...
                                                 (optional-dom-kwd optional-dom-kwd-arg optional-dom-kwd-proj) ...)))])
             (with-syntax ([((rev-sorted-dom-kwd rev-sorted-dom-kwd-arg rev-sorted-dom-kwd-proj) ...)
                            (reverse (syntax->list #'((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...)))]
                           [(rev-optional-dom-arg ...) (reverse (syntax->list #'(optional-dom-arg ...)))]
                           [(rev-optional-dom-proj ...) (reverse (syntax->list #'(optional-dom-proj ...)))])
               
               
               (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
                             [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
                             [(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
                             [(rng ...) (generate-temporaries (or rng-ctc '()))]
                             [(rng-ctc-x) (generate-temporaries '(rng-ctc-x))]
                             [(this-parameter ...)
                              (make-this-parameters (car (generate-temporaries '(this))))])
                 (quasisyntax/loc stx
                   (build-->
                    '->*
                    #,(if pre #`(λ () #,pre) #'#f)
                    #,(if post #`(λ () #,post) #'#f)
                    (list mandatory-dom ...)
                    (list optional-dom ...)
                    #,rest-ctc
                    (list mandatory-dom-kwd-ctc ...)
                    '(mandatory-dom-kwd ...)
                    (list optional-dom-kwd-ctc ...)
                    '(optional-dom-kwd ...)
                    #,(if rng-ctc
                          (with-syntax ([(rng-ctc ...) rng-ctc])
                            #'(list rng-ctc ...))
                          #''())
                    #,(if rng-ctc #f #t)
                    mtd? ->m-ctc?
                    (λ (blame neg-party blame-party-info f rng-ctc-x
                        mandatory-dom-proj ...  
                        #,@(if rest-ctc
                               #'(rest-proj)
                               #'())
                        optional-dom-proj ... 
                        mandatory-dom-kwd-proj ... 
                        optional-dom-kwd-proj ... 
                        rng-proj ...)
                      #,(create-chaperone 
                         #'blame #'neg-party #'blame-party-info #'f pre post
                         (syntax->list #'(this-parameter ...))
                         (syntax->list #'(mandatory-dom-proj ...))
                         (syntax->list #'(optional-dom-proj ...))
                         (if rest-ctc #'rest-proj #f)
                         (map list (syntax->list #'(mandatory-dom-kwd ...))
                              (syntax->list #'(mandatory-dom-kwd-proj ...)))
                         (map list (syntax->list #'(optional-dom-kwd ...))
                              (syntax->list #'(optional-dom-kwd-proj ...)))
                         (if rng-ctc (syntax->list #'(rng-proj ...)) #f)
                         #'rng-ctc-x))))))))))]))

(define (convert-pre-post/desc-to-boolean pre? b)
  (cond
    [(not b) #f]
    [(or (not b)
         (string? b)
         (and (list? b)
              (andmap string? b)))
     #f]
    [(equal? b #t) #t]
    [else
     (error '->* "expected #:~a to return (or/c boolean? string? (listof string?)), got ~e"
            (if pre? "pre" "post")
            b)]))
         

(define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))



;                     
;                     
;                     
;         ;       ;;; 
;          ;       ;; 
;           ;      ;; 
;   ;;;;;;;;;;  ;;;;; 
;           ;  ;;  ;; 
;          ;   ;;  ;; 
;         ;    ;;  ;; 
;               ;;;;;;
;                     
;                     
;                     

;; parses everything after the mandatory and optional doms in a ->d contract
(define-for-syntax (parse-leftover->d stx 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)]
                   [(dep-range #:post 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)
                         (not (keyword? (syntax-e #'rest-expr))))
                    (values #'(id rest-expr) #'leftover)]
                   [(#:rest id rest-expr . leftover)
                    (begin
                      (unless (identifier? #'id)
                        (raise-syntax-error #f "expected an identifier" stx #'id))
                      (when (keyword? (syntax-e #'rest-expr))
                        (raise-syntax-error #f "expected an expression, not a keyword" stx #'rest-expr)))]
                   [_ (values #f leftover)])]
                [(pre-cond leftover)
                 (syntax-case leftover ()
                   [(#:pre pre-cond . leftover)
                    (values #'pre-cond #'leftover)]
                   [(#:pre-cond pre-cond . leftover)
                    (values #'pre-cond #'leftover)]
                   [_ (values #f leftover)])]
                [(range leftover) 
                 (syntax-case leftover ()
                   [(range . leftover) (values #'range #'leftover)]
                   [_
                    (raise-syntax-error #f "expected a range expression, but found nothing" stx)])]
                [(post-cond leftover) 
                 (syntax-case leftover ()
                   [(#:post post-cond . leftover)
                    (begin
                      (syntax-case range (any)
                        [any (raise-syntax-error #f "cannot have a #:post with any as the range" stx #'post-cond)]
                        [_ (void)])
                      (values #'post-cond #'leftover))]
                   [(#:post-cond post-cond . leftover)
                    (begin
                      (syntax-case range (any)
                        [any (raise-syntax-error #f "cannot have a #:post-cond with any as the range" stx #'post-cond)]
                        [_ (void)])
                      (values #'post-cond #'leftover))]
                   [_ (values #f leftover)])])
    (syntax-case leftover ()
      [() 
       (values raw-optional-doms id/rest-id pre-cond range post-cond)]
      [_ 
       (raise-syntax-error #f "bad syntax" stx)])))

;; verify-->d-structure : syntax syntax -> syntax
;; returns the second argument when it has the proper shape for the first two arguments to ->d*
;; otherwise, raises a syntax error.
(define-for-syntax (verify-->d-structure stx doms)
  (syntax-case doms ()
    [((regular ...) (kwd ...))
     (let ([check-pair-shape
            (λ (reg)
              (syntax-case reg ()
                [(id dom)
                 (identifier? #'id)
                 (void)]
                [(a b)
                 (raise-syntax-error #f "expected an identifier" stx #'a)]
                [_
                 (raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))])
       (for-each check-pair-shape (syntax->list #'(regular ...)))
       (for-each
        (λ (kwd)
          (syntax-case kwd ()
            [(kwd ps)
             (check-pair-shape #'ps)]))
        (syntax->list #'(kwd ...))))])
  doms)

(define-for-syntax (make-this-transformer this-arg)
  (with-syntax ([this-arg this-arg])
    (make-set!-transformer
     (λ (sstx)
       (syntax-case sstx (set!)
         [(set! id arg)
          (raise-syntax-error #f 
                              "can't mutate this"
                              sstx)]
         [id
          (identifier? #'id)
          (syntax/loc sstx this-arg)]
         [(id . args)
          (datum->syntax sstx (cons #'this-arg #'args) sstx)])))))

(define-syntax (->d stx)
  (syntax-case stx ()
    [(_ (raw-mandatory-doms ...)
        .
        leftover)
     (let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover->d 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 ... 
                             optional-regular-id ... 
                             #,@(if id/rest 
                                    (with-syntax ([(id rst-ctc) id/rest])
                                      #'(id))
                                    #'())
                             kwd-id ...)])
             (with-syntax ([((rng-params ...) rng-ctcs)
                            (syntax-case range (any values)
                              [(values [id ctc] ...) #'((id ...) (ctc ...))]
                              [(values [id ctc] ... x . y) (raise-syntax-error #f "expected binding pair" stx #'x)]
                              [any #'(() #f)]
                              [[id ctc] #'((id) (ctc))]
                              [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
                           [mtd? (and (syntax-parameter-value #'making-a-method) #t)]
                           [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)])
               (let ([rng-underscores? 
                      (let ([is-underscore?
                             (λ (x) 
                               (syntax-case x (_)
                                 [_ #t]
                                 [else #f]))])
                        (cond
                          [(andmap is-underscore? (syntax->list #'(rng-params ...)))
                           #t]
                          [(ormap (λ (x) (and (is-underscore? x) x))
                                  (syntax->list #'(rng-params ...)))
                           =>
                           (λ (id)
                             (raise-syntax-error '->d 
                                                 "expected all of the identifiers to be underscores, or none of them to be"
                                                 stx
                                                 id))]
                          [else #f]))])
                 (let ([dup (check-duplicate-identifier 
                             (append (if rng-underscores? 
                                         '()
                                         (syntax->list #'(rng-params ...)))
                                     (syntax->list #'(dom-params ...))))])
                   (when dup
                     (raise-syntax-error #f "duplicate identifier" stx dup)))
                 #`(let-syntax ([parameterize-this
                                 (let ([old-param (syntax-parameter-value #'making-a-method)])
                                   (λ (stx)
                                     (syntax-case stx ()
                                       [(_ body) #'body]
                                       [(_ id body)
                                        (if (syntax? old-param)
                                            (with-syntax ([param old-param])
                                              (syntax/loc stx
                                                (syntax-parameterize
                                                 ([param (make-this-transformer #'id)])
                                                 body)))
                                            #'body)])))])
                     (syntax-parameterize 
                      ((making-a-method #f)) 
                      (build-->d mtd? ->m-ctc?
                                 (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 ((late-neg-->d-proj wrap-procedure) ->d-stct)
  (let* ([opt-count (length (base-->d-optional-dom-ctcs ->d-stct))]
         [mandatory-count (+ (length (base-->d-mandatory-dom-ctcs ->d-stct)) 
                             (if (base-->d-mtd? ->d-stct) 1 0))]
         [non-kwd-ctc-count (+ mandatory-count opt-count)]
         [arity 
          (cond
            [(base-->d-rest-ctc ->d-stct)
             (make-arity-at-least mandatory-count)]
            [else
             (let loop ([i 0])
               (cond
                 [(= i opt-count)
                  (list (+ mandatory-count i))]
                 [else
                  (cons (+ mandatory-count i) (loop (+ i 1)))]))])])
    (λ (blame)
      (define dom-blame (blame-add-context blame "the domain of" #:swap? #t))
      (define rng-blame (blame-add-range-context blame))
      (λ (val neg-party)
        (if (base-->d-rest-ctc ->d-stct)
            (check-procedure/more val
                                  (base-->d-mtd? ->d-stct)
                                  (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
                                  (base-->d-mandatory-keywords ->d-stct)
                                  (base-->d-optional-keywords ->d-stct)
                                  blame
                                  neg-party)
            (check-procedure val
                             (base-->d-mtd? ->d-stct)
                             (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
                             (length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length
                             (base-->d-mandatory-keywords ->d-stct)
                             (base-->d-optional-keywords ->d-stct)
                             blame
                             neg-party))
        (wrap-procedure
         val
         (make-keyword-procedure
          (λ (kwd-args kwd-arg-vals . raw-orig-args)
            (with-contract-continuation-mark
                (cons blame neg-party)
              (let* ([orig-args (if (base-->d-mtd? ->d-stct)
                                    (cdr raw-orig-args)
                                    raw-orig-args)]
                     [this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))]
                     [dep-pre-args
                      (build-dep-ctc-args non-kwd-ctc-count raw-orig-args (base-->d-rest-ctc ->d-stct)
                                          (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
                (when (base-->d-pre-cond ->d-stct)
                  (unless (apply (base-->d-pre-cond ->d-stct) dep-pre-args)
                    (raise-blame-error (blame-swap blame) #:missing-party neg-party
                                       val
                                       "#:pre violation~a"
                                       (build-values-string ", argument" dep-pre-args))))
                (apply 
                 values
                 
                 (append
                  
                  (let ([rng (let ([rng (base-->d-range ->d-stct)])
                               (cond
                                 [(not rng) #f]
                                 [(box? rng) 
                                  (map (λ (val) (apply val dep-pre-args))
                                       (unbox rng))]
                                 [else rng]))]
                        [rng-underscore? (box? (base-->d-range ->d-stct))])
                    (if rng
                        (list (λ orig-results
                                (with-contract-continuation-mark
                                  (cons blame neg-party)
                                  (let* ([range-count (length rng)]
                                         [post-args (append orig-results raw-orig-args)]
                                         [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
                                         [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
                                                                            post-args (base-->d-rest-ctc ->d-stct)
                                                                            (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
                                    (when (base-->d-post-cond ->d-stct)
                                      (unless (apply (base-->d-post-cond ->d-stct) dep-post-args)
                                        (raise-blame-error blame #:missing-party neg-party
                                                           val
                                                           "#:post violation~a~a"
                                                           (build-values-string ", argument" dep-pre-args)
                                                           (build-values-string (if (null? dep-pre-args)
                                                                                    ", result"
                                                                                    "\n result")
                                                                                orig-results))))
                                    
                                    (unless (= range-count (length orig-results))
                                      (raise-blame-error blame #:missing-party neg-party
                                                         val
                                                         "expected ~a results, got ~a"
                                                         range-count
                                                         (length orig-results)))
                                    (apply
                                     values
                                     (let loop ([results orig-results]
                                                [result-contracts rng])
                                       (cond
                                         [(null? result-contracts) '()]
                                         [else
                                          (cons
                                           (invoke-dep-ctc (car result-contracts)
                                                           (if rng-underscore? #f dep-post-args)
                                                           (car results)
                                                           rng-blame
                                                           neg-party)
                                           (loop (cdr results) (cdr result-contracts)))])))))))
                        null))
                  
                  ;; contracted keyword arguments
                  (let ([kwd-res (let loop ([all-kwds (base-->d-keywords ->d-stct)]
                                            [kwd-ctcs (base-->d-keyword-ctcs ->d-stct)] 
                                            [building-kwd-args kwd-args]
                                            [building-kwd-arg-vals kwd-arg-vals])
                                   (cond
                                     [(or (null? building-kwd-args) (null? all-kwds)) '()]
                                     [else (if (eq? (car all-kwds)
                                                    (car building-kwd-args))
                                               (cons (invoke-dep-ctc (car kwd-ctcs)
                                                                     dep-pre-args
                                                                     (car building-kwd-arg-vals)
                                                                     dom-blame
                                                                     neg-party)
                                                     (loop (cdr all-kwds) (cdr kwd-ctcs)
                                                           (cdr building-kwd-args)
                                                           (cdr building-kwd-arg-vals)))
                                               (loop (cdr all-kwds) (cdr kwd-ctcs)
                                                     building-kwd-args building-kwd-arg-vals))]))])
                    (if (null? kwd-res) null (list kwd-res)))
                  
                  
                  ;; this parameter (if necc.)
                  (if (base-->d-mtd? ->d-stct)
                      (list (car raw-orig-args))
                      '())
                  
                  ;; contracted ordinary arguments
                  (let loop ([args orig-args]
                             [non-kwd-ctcs (append (base-->d-mandatory-dom-ctcs ->d-stct)
                                                   (base-->d-optional-dom-ctcs ->d-stct))])
                    (cond
                      [(null? args) 
                       (if (base-->d-rest-ctc ->d-stct)
                           (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '()
                                           dom-blame neg-party)
                           '())]
                      [(null? non-kwd-ctcs) 
                       (if (base-->d-rest-ctc ->d-stct)
                           (invoke-dep-ctc (base-->d-rest-ctc ->d-stct)
                                           dep-pre-args args dom-blame neg-party)
                           
                           ;; ran out of arguments, but don't have a rest parameter.
                           ;; procedure-reduce-arity (or whatever the new thing is
                           ;; going to be called) should ensure this doesn't happen.
                           (error 'shouldnt\ happen))]
                      [else (cons (invoke-dep-ctc (car non-kwd-ctcs)
                                                  dep-pre-args (car args)
                                                  dom-blame neg-party)
                                  (loop (cdr args)
                                        (cdr non-kwd-ctcs)))]))))))))
         impersonator-prop:contracted ->d-stct)))))

(define (build-values-string desc dep-pre-args)
  (cond
    [(null? dep-pre-args) ""]
    [(null? (cdr dep-pre-args)) (format "~a was: ~e" desc (car dep-pre-args))]
    [else
     (apply
      string-append
      (format "~as were:" desc)
      (let loop ([lst dep-pre-args])
        (cond
          [(null? lst) '()]
          [else (cons (format "\n  ~e" (car lst))
                      (loop (cdr lst)))])))]))

;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst
(define (invoke-dep-ctc dep-ctc dep-args val blame neg-party)
  (let ([ctc (coerce-contract '->d (if dep-args
                                       (apply dep-ctc dep-args)
                                       dep-ctc))])
    (((get/build-late-neg-projection ctc)
      blame)
     val
     neg-party)))

;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args)
  (append 
   
   ;; ordinary args (possibly including `this' as the first element)
   (let loop ([count non-kwd-ctc-count]
              [args args])
     (cond
       [(zero? count) 
        (if rest-arg?
            (list args)
            '())]
       [(null? args) (cons the-unsupplied-arg (loop (- count 1) null))]
       [else (cons (car args) (loop (- count 1) (cdr args)))]))
   
   ;; kwd args
   (let loop ([all-kwds all-kwds]
              [kwds supplied-kwds]
              [args supplied-args])
     (cond
       [(null? all-kwds) null]
       [else (let* ([kwd (car all-kwds)]
                    [kwd-matches? (and (not (null? kwds)) (eq? (car kwds) kwd))])
               (if kwd-matches?
                   (cons (car args) (loop (cdr all-kwds) (cdr kwds) (cdr args)))
                   (cons the-unsupplied-arg (loop (cdr all-kwds) kwds args))))]))))

(define-struct unsupplied-arg ())
(define the-unsupplied-arg (make-unsupplied-arg))

(define (build-->d mtd? mctc?
                   mandatory-dom-ctcs optional-dom-ctcs
                   mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs
                   rest-ctc pre-cond range post-cond
                   mandatory-kwds optional-kwds
                   name-wrapper)
  (let ([kwd/ctc-pairs (sort
                        (map cons 
                             (append mandatory-kwds optional-kwds)
                             (append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
                        (λ (x y) (keyword<? (car x) (car y))))])
    (make-impersonator-->d mtd? mctc?
                           mandatory-dom-ctcs optional-dom-ctcs
                           (map cdr kwd/ctc-pairs)
                           rest-ctc pre-cond range post-cond
                           (map car kwd/ctc-pairs)
                           mandatory-kwds
                           optional-kwds
                           name-wrapper)))

(define (->d-name ctc) 
  (let* ([name (if (base-->d-mctc? ctc) '->dm '->d)]
         [counting-id 'x]
         [ids '(x y z w)]
         [next-id
          (λ ()
            (cond
              [(pair? ids)
               (begin0 (car ids)
                       (set! ids (cdr ids)))]
              [(null? ids)
               (begin0 
                 (string->symbol (format "~a0" counting-id))
                 (set! ids 1))]
              [else
               (begin0 
                 (string->symbol (format "~a~a" counting-id ids))
                 (set! ids (+ ids 1)))]))])
    `(,name (,@(map (λ (x) `(,(next-id) ...)) (base-->d-mandatory-dom-ctcs ctc))
           ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (base-->d-mandatory-keywords ctc))))
          (,@(map (λ (x) `(,(next-id) ...)) (base-->d-optional-dom-ctcs ctc))
           ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (base-->d-optional-keywords ctc))))
          ,@(if (base-->d-rest-ctc ctc)
                (list '#:rest (next-id) '...)
                '())
          ,@(if (base-->d-pre-cond ctc)
                (list '#:pre '...)
                (list))
          ,(let ([range (base-->d-range ctc)])
             (cond
               [(not range) 'any]
               [(box? range)
                (let ([range (unbox range)])
                  (cond
                    [(and (not (null? range))
                          (null? (cdr range)))
                     `[_ ...]]
                    [else
                     `(values ,@(map (λ (x) `(_ ...)) range))]))]
               [(and (not (null? range))
                     (null? (cdr range)))
                `[,(next-id) ...]]
               [else
                `(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
          ,@(if (base-->d-post-cond ctc)
                (list '#:post '...)
                (list)))))

(define (->d-first-order ctc)
  (let* ([mtd? (base-->d-mtd? ctc)]
         [dom-length (length (base-->d-mandatory-dom-ctcs ctc))]
         [optionals (length (base-->d-optional-dom-ctcs ctc))]
         [mandatory-kwds (base-->d-mandatory-keywords ctc)]
         [optional-kwds (base-->d-optional-keywords ctc)])
    (λ (val)
      (if (base-->d-rest-ctc ctc)
          (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f #f)
          (check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f #f)))))
(define (->d-stronger? this that) (eq? this that))

;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that
;; is under the contract, and "dr???" refers to the arguments & the results of the function that 
;; is under the contract.
;; the `box' in the range only serves to differentiate between range contracts that depend on
;; both the domain and the range from those that depend only on the domain (and thus, those
;; that can be applied early)
(define-struct base-->d (mtd?                ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
                         mctc?               ;; boolean; indicates if this contract was constructed with ->dm (from racket/class)
                         mandatory-dom-ctcs  ;; (listof (-> d??? ctc))
                         optional-dom-ctcs   ;; (listof (-> d??? ctc))
                         keyword-ctcs        ;; (listof (-> d??? ctc))
                         rest-ctc            ;; (or/c false/c (-> d??? ctc))
                         pre-cond            ;; (-> d??? boolean)
                         range               ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc))))
                         post-cond           ;; (-> dr??? boolean)
                         keywords            ;; (listof keywords) -- sorted by keyword<
                         mandatory-keywords  ;; (listof keywords) -- sorted by keyword<
                         optional-keywords   ;; (listof keywords) -- sorted by keyword<
                         name-wrapper))      ;; (-> proc proc) 

;; Factored out in case there are ever chaperone ->d contracts.
;; However, to do that, you'd either a) have to somehow check
;; that the subcontracts are chaperones or b) allow contract
;; application-time failures if the subpieces did not convert
;; appropriately.  b) might be okay, but we should think about
;; it first.  At the very least, the projection function would
;; need to add checks in the appropriate places.
(define-struct (impersonator-->d base-->d) ()
  #:property prop:custom-write custom-write-property-proc
  #:property prop:contract
  (build-contract-property
   #:late-neg-projection (late-neg-->d-proj impersonate-procedure)
   #:name ->d-name
   #:first-order ->d-first-order
   #:stronger ->d-stronger?))

;                                                                                 
;                                                                                 
;                                                                                 
;                                       ;;;;                      ;;;;            
;                                       ;;;;                      ;;;;            
;  ;;;;;;;  ;;; ;;; ;;; ;;;       ;;;;; ;;;; ;;;    ;;;     ;;;;; ;;;; ;;;  ;;;;; 
;  ;;;;;;;; ;;;;;;; ;;;;;;;      ;;;;;; ;;;;;;;;;  ;;;;;   ;;;;;; ;;;; ;;; ;;;;;; 
;      ;;;; ;;;; ;; ;;;; ;;     ;;;;;;; ;;;; ;;;; ;;;; ;; ;;;;;;; ;;;;;;;  ;;;;   
;   ;;;;;;; ;;;;    ;;;;        ;;;;    ;;;; ;;;; ;;;;;;; ;;;;    ;;;;;;;   ;;;;  
;  ;;  ;;;; ;;;;    ;;;;        ;;;;;;; ;;;; ;;;; ;;;;;   ;;;;;;; ;;;; ;;;   ;;;; 
;  ;;;;;;;; ;;;;    ;;;;         ;;;;;; ;;;; ;;;;  ;;;;;;  ;;;;;; ;;;; ;;; ;;;;;; 
;   ;; ;;;; ;;;;    ;;;;          ;;;;; ;;;; ;;;;   ;;;;    ;;;;; ;;;; ;;; ;;;;;  
;                                                                                 
;                                                                                 
;                                                                                 

;; ----------------------------------------
;; Checks and error functions used in macro expansions

;; procedure-accepts-and-more? : procedure number -> boolean
;; returns #t if val accepts dom-length arguments and
;; any number of arguments more than dom-length. 
;; returns #f otherwise.
(define (procedure-accepts-and-more? val dom-length)
  (let ([arity (procedure-arity val)])
    (cond
      [(number? arity) #f]
      [(arity-at-least? arity)
       (<= (arity-at-least-value arity) dom-length)]
      [else
       (let ([min-at-least (let loop ([ars arity]
                                      [acc #f])
                             (cond
                               [(null? ars) acc]
                               [else (let ([ar (car ars)])
                                       (cond
                                         [(arity-at-least? ar)
                                          (if (and acc
                                                   (< acc (arity-at-least-value ar)))
                                              (loop (cdr ars) acc)
                                              (loop (cdr ars) (arity-at-least-value ar)))]
                                         [(number? ar)
                                          (loop (cdr ars) acc)]))]))])
         (and min-at-least
              (begin
                (let loop ([counts (sort (filter number? arity) >)])
                  (unless (null? counts)
                    (let ([count (car counts)])
                      (cond
                        [(= (+ count 1) min-at-least)
                         (set! min-at-least count)
                         (loop (cdr counts))]
                        [(< count min-at-least)
                         (void)]
                        [else (loop (cdr counts))]))))
                (<= min-at-least dom-length))))])))

(define (get-mandatory-keywords f)
  (let-values ([(mandatory optional) (procedure-keywords f)])
    mandatory))

(define (no-mandatory-keywords? f)
  (let-values ([(mandatory optional) (procedure-keywords f)])
    (null? mandatory)))

;; check-procedure : ... (or/c #f blame) -> (or/c boolean? void?)
;; if blame is #f, then just return a boolean indicating that this matched 
;;   (for use in arity checking)
(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords
                         blame neg-party)
  (define passes?
    (and (procedure? val)
         (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
         (keywords-match mandatory-kwds optional-keywords val)))
  (cond
    [blame
     (unless passes?
       (raise-blame-error
        blame #:missing-party neg-party
        val
        '(expected " a ~a that accepts ~a~a~a argument~a~a~a" given: "~e")
        (if mtd? "method" "procedure")
        (if (zero? dom-length) "no" dom-length)
        (if (null? optionals) "" " mandatory")
        (if (null? mandatory-kwds) "" " ordinary")
        (if (= 1 dom-length) "" "s")
        (if (zero? optionals) ""
            (format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
        (keyword-error-text mandatory-kwds optional-keywords)
        val))]
    [else
     passes?]))

(define (procedure-arity-includes?/optionals f base optionals)
  (cond
    [(zero? optionals) (procedure-arity-includes? f base #t)]
    [else (and (procedure-arity-includes? f (+ base optionals) #t)
               (procedure-arity-includes?/optionals f base (- optionals 1)))]))

(define (keywords-match mandatory-kwds optional-kwds val)
  (let-values ([(proc-mandatory proc-all) (procedure-keywords val)])
    (and ;; proc accepts all ctc's mandatory keywords
         (or (not proc-all)
             (andmap (λ (kwd) (member kwd proc-all))
                     mandatory-kwds))
         ;; proc's mandatory keywords are still mandatory in ctc
         (andmap (λ (kwd) (member kwd mandatory-kwds))
                 proc-mandatory)
         ;; proc accepts (but does not require) ctc's optional keywords
         ;;
         ;; if proc-all is #f, then proc accepts all keywords and thus
         ;; this is triviably true (e.g. result of make-keyword-procedure)
         (or (not proc-all)
             (andmap (λ (kwd) (and (member kwd proc-all)
                                   (not (member kwd proc-mandatory))))
                     optional-kwds)))))

(define (keyword-error-text mandatory-keywords optional-keywords)
  (define (format-keywords-error type kwds)
    (cond
      [(null? kwds) ""]
      [(null? (cdr kwds))
       (format "the ~a keyword ~a" type (car kwds))]
      [else
       (format
        "the ~a keywords ~a~a"
        type
        (car kwds)
        (apply string-append (map (λ (x) (format " ~a" x)) (cdr kwds))))]))
  (cond
    [(and (null? optional-keywords) (null? mandatory-keywords)) " without any keywords"]
    [(null? optional-keywords)
     (string-append " and " (format-keywords-error 'mandatory mandatory-keywords))]
    [(null? mandatory-keywords)
     (string-append " and " (format-keywords-error 'optional optional-keywords))]
    [else
     (string-append ", "
                    (format-keywords-error 'mandatory mandatory-keywords)
                    ", and "
                    (format-keywords-error 'optional optional-keywords))]))

;; check-procedure/more : ... (or/c #f blame) -> (or/c boolean? void?)
;; if blame is #f, then just return a boolean indicating that this matched 
;;   (for use in arity checking)
(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame neg-party)
  (define passes?
    (and (procedure? val)
         (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
         (keywords-match mandatory-kwds optional-kwds val)))
  (cond
    [blame
     (unless passes?
       (raise-blame-error
        blame
        val
        '(expected " a ~a that accepts ~a argument~a and arbitrarily more~a" given: "~e")
        (if mtd? "method" "procedure")
        (cond
          [(zero? dom-length) "no"]
          [else dom-length])
        (if (= 1 dom-length) "" "s")
        (keyword-error-text mandatory-kwds optional-kwds)
        val))]
    [else
     passes?]))

(define (bad-number-of-results blame val rng-len args [case-context #f]
                               #:missing-party [missing-party #f])
  (define num-values (length args))
  (define blame-case (if case-context 
                         (blame-add-context blame (format "the ~a case of" (n->th (+ case-context 1))))
                         blame))
  (raise-blame-error (blame-add-range-context blame-case)
                     #:missing-party missing-party
                     val 
                     "expected ~a value~a, returned ~a value~a"
                     rng-len (if (= rng-len 1) "" "s")
                     num-values (if (= num-values 1) "" "s")))

(define (blame-add-range-context blame)
  (blame-add-context blame "the range of"))

(define (blame-add-nth-arg-context blame n)
  (blame-add-context blame
                     (format "the ~a argument of" (n->th n))))

;; timing & size tests

#;
(begin
  (require (prefix-in mz: mzlib/contract))
  (define (time-test f)
    (time
     (let loop ([n 2000])
       (unless (zero? n)
         (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
         (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
         (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
         (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
         (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
         (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
         (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
         (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1)
         (loop (- n 1))))))
  
  (define (size stx)
    (let ([sp (open-output-string)])
      (write (compile stx) sp)
      (close-output-port sp)
      (string-length (get-output-string sp))))
  
  'raw
  (size #'(λ (x) x))
  (time-test (λ (x) x))
  
  '->
  (size #'(-> number? number?))
  (time-test (contract (-> number? number?) (λ (x) x) 'pos 'neg))
  
  'mz:->
  (size #'(mz:-> number? number?))
  (time-test (contract (mz:-> number? number?) (λ (x) x) 'pos 'neg))
  
  '->*
  (size #'(->* (number?) () number?))
  (time-test (contract (->* (number?) () number?) (λ (x) x) 'pos 'neg))
  
  'mz:->*
  (size #'(mz:->* (number?) any/c (number?)))
  (time-test (contract (mz:->* (number?) any/c (number?)) (λ (x . y) x) 'pos 'neg))
  
  'case->
  (size #'(case-> (-> number? number?)))
  (time-test (contract (case-> (-> number? number?)) (λ (x) x) 'pos 'neg))
  
  'mz:case->
  (size #'(mz:case-> (-> number? number?)))
  (time-test (contract (mz:case-> (-> number? number?)) (λ (x) x) 'pos 'neg))
  
  '->d
  (size #'(->d ([x number?]) () [r number?]))
  (time-test (contract (->d ([x number?]) () [r number?]) (λ (x) x) 'pos 'neg))
  
  'mz:->r
  (size #'(mz:->r ([x number?]) number?))
  (time-test (contract (mz:->r ([x number?]) number?) (λ (x) x) 'pos 'neg))
  
  'object-contract
  (size #'(object-contract [m (-> number? number?)]))
  (time-test 
   (let ([o (contract (object-contract [m (-> number? number?)])
                      (new (class object% (define/public (m x) x) (super-new)))
                      'pos
                      'neg)])
     (λ (x) (send o m x))))
  
  
  'mz:object-contract
  (size #'(mz:object-contract [m (mz:-> number? number?)]))
  (time-test 
   (let ([o (contract (mz:object-contract [m (mz:-> number? number?)])
                      (new (class object% (define/public (m x) x) (super-new)))
                      'pos
                      'neg)])
     (λ (x) (send o m x)))))


(define-syntax (-> stx) 
  #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx)))

;; this is to make the expanded versions a little easier to read
(define-syntax (values/drop stx)
  (syntax-case stx ()
    [(_ arg) #'arg]
    [(_ args ...) #'(values args ...)]))
