#lang scheme/base

#|

v4 done:

- added mandatory keywords to ->
- rewrote ->* using new notation

v4 todo:

- rewrite ->d

- remove opt-> opt->* ->pp ->pp-rest ->r ->d*

- raise-syntax-errors
  . multiple identical keywords syntax error, sort-keywords
  . split-doms

|#

(require "contract-guts.ss"
         "contract-arr-checks.ss"
         "contract-opt.ss")
(require (for-syntax scheme/base)
         (for-syntax "contract-opt-guts.ss")
         (for-syntax "contract-helpers.ss")
         (for-syntax "contract-arr-obj-helpers.ss")
         (for-syntax syntax/stx)
         (for-syntax syntax/name))

(provide ->
         ->d
         ->*
         ->d*
         ->r
         ->pp
         ->pp-rest
         case->
         opt->
         opt->*
         unconstrained-domain->)

(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 ([proj-x ((proj-get rngs-x) rngs-x)] ...)
             (make-proj-contract
              (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
              (λ (pos-blame neg-blame src-info orig-str)
                (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
                  (λ (val)
                    (if (procedure? val)
                        (λ args
                          (let-values ([(res-x ...) (apply val args)])
                            (values (p-app-x res-x) ...)))
                        (raise-contract-error val
                                              src-info
                                              pos-blame
                                              orig-str
                                              "expected a procedure")))))
              procedure?))))]))

(define (build--> name
                  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? func)
  (let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
    (make--> 
     (map cc doms/c-or-p) (map cc optional-doms/c-or-p) (and doms-rest/c-or-p-or-f (cc doms-rest/c-or-p-or-f))
     (map cc mandatory-kwds/c-or-p) mandatory-kwds (map cc optional-kwds/c-or-p) optional-kwds
     (map cc rngs/c-or-p) rng-any?
     func)))

;; 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
;; 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/prop -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func)
  ((proj-prop (λ (ctc) 
                (let* ([doms-proj (map (λ (x) ((proj-get x) x)) 
                                       (if (->-dom-rest/c ctc)
                                           (append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
                                           (->-doms/c ctc)))]
                       [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))]
                       [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))]
                       [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))]
                       [optional-kwds-proj (map (λ (x) ((proj-get x) x)) (->-optional-kwds/c ctc))]
                       [mandatory-keywords (->-mandatory-kwds ctc)]
                       [optional-keywords (->-optional-kwds ctc)]
                       [func (->-func ctc)]
                       [dom-length (length (->-doms/c ctc))]
                       [optionals-length (length (->-optional-doms/c ctc))]
                       [has-rest? (and (->-dom-rest/c ctc) #t)])
                  (λ (pos-blame neg-blame src-info orig-str)
                    (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
                                             doms-proj)]
                          [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
                                                      doms-optional-proj)]
                          [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
                                               rngs-proj)]
                          [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
                                                       mandatory-kwds-proj)]
                          [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
                                                      optional-kwds-proj)])
                      (apply func
                             (λ (val) (if has-rest?
                                          (check-procedure/more val dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
                                          (check-procedure val dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
                             (append partial-doms partial-optional-doms 
                                     partial-mandatory-kwds partial-optional-kwds
                                     partial-ranges)))))))
   (name-prop (λ (ctc) (single-arrow-name-maker 
                        (->-doms/c ctc)
                        (->-optional-doms/c ctc)
                        (->-dom-rest/c ctc)
                        (->-mandatory-kwds/c ctc)
                        (->-mandatory-kwds ctc)
                        (->-optional-kwds/c ctc)
                        (->-optional-kwds ctc)
                        (->-rng-any? ctc)
                        (->-rngs/c ctc))))
   (first-order-prop
    (λ (ctc)
      (λ (x)
        (let ([l (length (->-doms/c ctc))])
          (and (procedure? x) 
               (if (->-dom-rest/c ctc)
                   (procedure-accepts-and-more? x l)
                   (procedure-arity-includes? x l))
               (let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)])
                 (and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
                      (andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
                              (->-mandatory-kwds ctc))))
               #t)))))
   (stronger-prop
    (λ (this that)
      (and (->? that)
           (= (length (->-doms/c that)) (length (->-doms/c this)))
           (andmap contract-stronger? (->-doms/c that) (->-doms/c this))
           
           (equal? (->-mandatory-kwds this) (->-mandatory-kwds that))
           (andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this))
           
           (equal? (->-optional-kwds this) (->-optional-kwds that))
           (andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this))
           
           (= (length (->-rngs/c that)) (length (->-rngs/c this)))
           (andmap contract-stronger? (->-rngs/c this) (->-rngs/c that)))))))

(define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs)
  (cond
    [(or doms-rest 
         (not (null? optional-kwds))
         (not (null? optional-doms/c)))
     (let ([range
            (cond
              [rng-any? 'any]
              [else (apply build-compound-type-name rngs)])])
       (apply
        build-compound-type-name 
        '->*
        (apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c))))
        (apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c))))
        (if doms-rest
            (list doms-rest range)
            (list range))))]
    [else
     (let ([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 
              '->
              (append doms/c
                      (apply append (map list kwds kwds/c))
                      (list rng-name))))]))

;; sort-keywords : syntax (listof syntax[(kwd . whatever)] -> (listof syntax[(kwd . whatever)])
;; sorts a list of syntax according to the keywords in the list
(define-for-syntax (sort-keywords stx kwd/ctc-pairs)
  (define (insert x lst)
    (cond
      [(null? lst) (list x)]
      [else
       (let ([fst-kwd (syntax-e (car (syntax-e (car lst))))]
             [x-kwd (syntax-e (car (syntax-e x)))])
         (cond
           [(equal? x-kwd fst-kwd)
            (raise-syntax-error #f 
                                "duplicate keyword"
                                stx
                                (car x))]
           [(keyword<? x-kwd fst-kwd)
            (cons x lst)]
           [else (cons (car lst) (insert x (cdr lst)))]))]))
  
  (let loop ([pairs kwd/ctc-pairs])
    (cond
      [(null? pairs) null]
      [else (insert (car pairs) (loop (cdr pairs)))])))

(define-for-syntax (split-doms stx name raw-doms)
  (let loop ([raw-doms raw-doms]
             [doms '()]
             [kwd-doms '()])
    (syntax-case raw-doms ()
      [() (list (reverse doms)
                (sort-keywords stx kwd-doms))]
      [(kwd arg . rest)
       (and (keyword? (syntax-e #'kwd))
            (not (keyword? (syntax-e #'arg))))
       (loop #'rest
             doms
             (cons #'(kwd arg) kwd-doms))]
      [(kwd arg . rest)
       (and (keyword? (syntax-e #'kwd))
            (keyword? (syntax-e #'arg)))
       (raise-syntax-error name
                           "expected a keyword followed by a contract"
                           stx
                           #'kwd)]
      [(kwd)
       (keyword? (syntax-e #'kwd))
       (raise-syntax-error name
                           "expected a keyword to be followed by a contract"
                           stx
                           #'kwd)]
      [(x . rest)
       (loop #'rest (cons #'x doms) kwd-doms)])))

(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 ...)))])
           (syntax-case* #'last-one (-> any values) module-or-top-identifier=?
             [any
              (with-syntax ([(ignored) (generate-temporaries (syntax (rng)))])
                (values (syntax (dom-ctc ...))
                        (syntax (ignored))
                        (syntax (dom-kwd-ctc-id ...))
                        (syntax (doms ...))
                        (syntax (any/c))
                        (syntax (dom-kwd-ctc ...))
                        (syntax (dom-kwd ...))
                        (syntax ((args ... keyword-formal-parameters ...) (val (dom-ctc args) ... keyword-call/ctc ...)))
                        #t))]
             [(values rngs ...)
              (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
                            [(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
                (values (syntax (dom-ctc ...))
                        (syntax (rng-ctc ...))
                        (syntax (dom-kwd-ctc-id ...))
                        (syntax (doms ...))
                        (syntax (rngs ...))
                        (syntax (dom-kwd-ctc ...))
                        (syntax (dom-kwd ...))
                        (syntax ((args ... keyword-formal-parameters ...) 
                                 (let-values ([(rng-x ...) (val (dom-ctc args) ... keyword-call/ctc ...)])
                                   (values (rng-ctc rng-x) ...))))
                        #f))]
             [rng
              (with-syntax ([(rng-ctc) (generate-temporaries (syntax (rng)))])
                (values (syntax (dom-ctc ...))
                        (syntax (rng-ctc))
                        (syntax (dom-kwd-ctc-id ...))
                        (syntax (doms ...))
                        (syntax (rng))
                        (syntax (dom-kwd-ctc ...))
                        (syntax (dom-kwd ...))
                        (syntax ((args ... keyword-formal-parameters ...) (rng-ctc (val (dom-ctc args) ... keyword-call/ctc ...))))
                        #f))]))))]))

;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define-for-syntax (->/proc/main stx)
  (let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)])
    (with-syntax ([(args body) inner-args/body])
      (with-syntax ([(dom-names ...) dom-names]
                    [(rng-names ...) rng-names]
                    [(kwd-names ...) kwd-names]
                    [(dom-ctcs ...) dom-ctcs]
                    [(rng-ctcs ...) rng-ctcs]
                    [(kwd-ctcs ...) kwd-ctcs]
                    [(kwds ...) kwds]
                    [inner-lambda 
                     (add-name-prop
                      (syntax-local-infer-name stx)
                      (syntax (lambda args body)))]
                    [use-any? use-any?])
        (with-syntax ([outer-lambda
                       (syntax
                        (lambda (chk dom-names ... kwd-names ... rng-names ...)
                          (lambda (val)
                            (chk val)
                            inner-lambda)))])
          (values
           (syntax 
            (build--> '->
                      (list dom-ctcs ...) '() #f
                      (list kwd-ctcs ...) '(kwds ...) '() '()
                      (list rng-ctcs ...) use-any?
                      outer-lambda))
           inner-args/body
           (syntax (dom-names ... rng-names ...))))))))
  
(define-syntax (-> stx) 
  (let-values ([(stx _1 _2) (->/proc/main stx)])
    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))))))

;; ->*/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 ...) (raw-optional-dom ...) . rst)
     (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-dom ...))])
       ;(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 ...)))])
             
             
             (let-values ([(rest-ctc rng-ctc)
                           ;; 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
                           (syntax-case #'rst (any)
                             [(any) (values #f #f)]
                             [(rest-expr any) (values #'rest-expr #f)]
                             [((res-ctc ...)) (values #f #'(res-ctc ...))]
                             [(rest-expr (res-ctc ...)) (values #'rest-expr #'(res-ctc ...))]
                             [_ (raise-syntax-error #f "bad syntax" stx)])])
               (with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
                             [(rng ...) (generate-temporaries (or rng-ctc '()))])
                 #`(build-->
                    '->*
                    (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)
                    (λ (chk mandatory-dom-proj ...  
                            #,@(if rest-ctc
                                   #'(rest-proj)
                                   #'())
                            optional-dom-proj ... 
                            mandatory-dom-kwd-proj ... 
                            optional-dom-kwd-proj ... 
                            rng-proj ...)
                      (λ (f)
                        (chk f)
                        #,(add-name-prop
                           (syntax-local-infer-name stx)
                           #`(λ (mandatory-dom-arg ... 
                                 [optional-dom-arg unspecified-dom] ... 
                                 mandatory-dom-kwd/var-seq ... 
                                 optional-dom-kwd/var-seq ...
                                 #,@(if rest-ctc #'rest #'()))
                               (let*-values ([(kwds kwd-args) (values '() '())]
                                             [(kwds kwd-args) (if (eq? unspecified-dom rev-sorted-dom-kwd-arg)
                                                                  (values kwds kwd-args)
                                                                  (values (cons 'rev-sorted-dom-kwd kwds)
                                                                          (cons (rev-sorted-dom-kwd-proj rev-sorted-dom-kwd-arg)
                                                                                kwd-args)))] 
                                             ...
                                             [(opt-args) #,(if rest-ctc 
                                                               #'(rest-proj rest)
                                                               #''())]
                                             [(opt-args) (if (eq? unspecified-dom rev-optional-dom-arg)
                                                             opt-args
                                                             (cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))]
                                             ...)
                                 #,(let ([call #'(keyword-apply f kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args)])
                                     (if rng-ctc
                                         #`(let-values ([(rng ...) #,call])
                                             (values (rng-proj rng) ...))
                                         call))))))))))))))]))
           
(define-syntax (->* stx) (->*/proc/main stx))

(define-for-syntax (select/h stx err-name ctxt-stx)
  (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
    [(-> . args) ->/h]
    [(->* . args) ->*/h]
    [(->d . args) ->d/h]
    [(->d* . args) ->d*/h]
    [(->r . args) ->r/h]
    [(->pp . args) ->pp/h]
    [(->pp-rest . args) ->pp-rest/h]
    [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
    [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))

(define-syntax (->d stx) (make-/proc #f ->d/h stx))
(define-syntax (->d* stx) (make-/proc #f ->d*/h stx))
(define-syntax (->r stx) (make-/proc #f ->r/h stx))
(define-syntax (->pp stx) (make-/proc #f ->pp/h stx))
(define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx))
(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h))
(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))

;;
;; arrow opter
;;
(define/opter (-> opt/i opt/info stx)
  (define (opt/arrow-ctc doms rngs)
    (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
                                               (generate-temporaries rngs))]
                  [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
                   (let loop ([vars dom-vars]
                              [doms doms]
                              [next-doms null]
                              [lifts-doms null]
                              [superlifts-doms null]
                              [partials-doms null]
                              [stronger-ribs null])
                     (cond
                       [(null? doms) (values (reverse next-doms)
                                             lifts-doms
                                             superlifts-doms
                                             partials-doms
                                             stronger-ribs)]
                       [else
                        (let-values ([(next lift superlift partial _ __ this-stronger-ribs)
                                      (opt/i (opt/info-swap-blame opt/info) (car doms))])
                          (loop (cdr vars)
                                (cdr doms)
                                (cons (with-syntax ((next next)
                                                    (car-vars (car vars)))
                                        (syntax (let ((val car-vars)) next)))
                                      next-doms)
                                (append lifts-doms lift)
                                (append superlifts-doms superlift)
                                (append partials-doms partial)
                                (append this-stronger-ribs stronger-ribs)))]))]
                  [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng)
                   (let loop ([vars rng-vars]
                              [rngs rngs]
                              [next-rngs null]
                              [lifts-rngs null]
                              [superlifts-rngs null]
                              [partials-rngs null]
                              [stronger-ribs null])
                     (cond
                       [(null? rngs) (values (reverse next-rngs)
                                             lifts-rngs
                                             superlifts-rngs
                                             partials-rngs
                                             stronger-ribs)]
                       [else
                        (let-values ([(next lift superlift partial _ __ this-stronger-ribs)
                                      (opt/i opt/info (car rngs))])
                          (loop (cdr vars)
                                (cdr rngs)
                                (cons (with-syntax ((next next)
                                                    (car-vars (car vars)))
                                        (syntax (let ((val car-vars)) next)))
                                      next-rngs)
                                (append lifts-rngs lift)
                                (append superlifts-rngs superlift)
                                (append partials-rngs partial)
                                (append this-stronger-ribs stronger-ribs)))]))])
      (values
       (with-syntax ((pos (opt/info-pos opt/info))
                     (src-info (opt/info-src-info opt/info))
                     (orig-str (opt/info-orig-str opt/info))
                     ((dom-arg ...) dom-vars)
                     ((rng-arg ...) rng-vars)
                     ((next-dom ...) next-doms)
                     (dom-len (length dom-vars))
                     ((next-rng ...) next-rngs))
         (syntax (begin
                   (check-procedure val dom-len 0 '() '() #| keywords |# src-info pos orig-str)
                   (λ (dom-arg ...)
                     (let-values ([(rng-arg ...) (val next-dom ...)])
                       (values next-rng ...))))))
       (append lifts-doms lifts-rngs)
       (append superlifts-doms superlifts-rngs)
       (append partials-doms partials-rngs)
       #f
       #f
       (append stronger-ribs-dom stronger-ribs-rng))))
  
  (define (opt/arrow-any-ctc doms)
    (let*-values ([(dom-vars) (generate-temporaries doms)]
                  [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
                   (let loop ([vars dom-vars]
                              [doms doms]
                              [next-doms null]
                              [lifts-doms null]
                              [superlifts-doms null]
                              [partials-doms null]
                              [stronger-ribs null])
                     (cond
                       [(null? doms) (values (reverse next-doms)
                                             lifts-doms
                                             superlifts-doms
                                             partials-doms
                                             stronger-ribs)]
                       [else
                        (let-values ([(next lift superlift partial flat _ this-stronger-ribs)
                                      (opt/i (opt/info-swap-blame opt/info) (car doms))])
                          (loop (cdr vars)
                                (cdr doms)
                                (cons (with-syntax ((next next)
                                                    (car-vars (car vars)))
                                        (syntax (let ((val car-vars)) next)))
                                      next-doms)
                                (append lifts-doms lift)
                                (append superlifts-doms superlift)
                                (append partials-doms partial)
                                (append this-stronger-ribs stronger-ribs)))]))])
      (values
       (with-syntax ((pos (opt/info-pos opt/info))
                     (src-info (opt/info-src-info opt/info))
                     (orig-str (opt/info-orig-str opt/info))
                     ((dom-arg ...) dom-vars)
                     ((next-dom ...) next-doms)
                     (dom-len (length dom-vars)))
         (syntax (begin
                   (check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str)
                   (λ (dom-arg ...)
                     (val next-dom ...)))))
       lifts-doms
       superlifts-doms
       partials-doms
       #f
       #f
       stronger-ribs-dom)))
  
  (syntax-case* stx (-> values any) module-or-top-identifier=?
    [(-> dom ... (values rng ...))
     (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
         (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword 
         (opt/arrow-ctc (syntax->list (syntax (dom ...)))
                        (syntax->list (syntax (rng ...)))))]
    [(-> dom ... any)
     (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
         (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword 
         (opt/arrow-any-ctc (syntax->list (syntax (dom ...)))))]
    [(-> dom ... rng)
     (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
         (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword 
         (opt/arrow-ctc (syntax->list (syntax (dom ...)))
                        (list #'rng)))]))