#lang racket/base

(require "guts.rkt"
         "arrow.rkt"
         "opt.rkt"
         racket/stxparam
         
         (for-syntax racket/base
                     syntax/stx
                     syntax/name
                     "arr-i-parse.rkt"
                     "opt-guts.rkt"
                     "helpers.rkt"
                     "arr-util.rkt"))

(provide ->i)

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

;; parses everything after the mandatory and optional doms in a ->d contract
(define-for-syntax (parse-leftover 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 . more)
                    (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 (id2 ...) rest-expr] . leftover)
                    (and (identifier? #'id)
                         (andmap identifier? (syntax->list #'(id2 ...)))
                         (not (keyword? (syntax-e #'rest-expr))))
                    (values #'(id rest-expr) #'leftover)]
                   [(#:rest something . leftover)
                    (raise-syntax-error #f "expected id+ctc" stx #'something)]
                   [_ (values #f leftover)])]
                [(pre-cond leftover)
                 (syntax-case leftover ()
                   [(#:pre (id ...) 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 (id ...) 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))]
                   [_ (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-->i-structure : syntax syntax -> syntax
;; returns the second argument when it has the proper shape for the first two arguments to ->i
;; otherwise, raises a syntax error.
;; also: drops the extra identifiers in the ->i.
(define-for-syntax (verify-->i-structure stx doms)
  (syntax-case doms ()
    [((regular ...) (kwd ...))
     (let ([check-pair-shape
            (λ (reg)
              (syntax-case reg ()
                [(id dom)
                 (identifier? #'id)
                 reg]
                [(a b)
                 (raise-syntax-error #f "expected an identifier" stx #'a)]

                [(id (id2 ...) dom)
                 (and (identifier? #'id)
                      (andmap identifier? (syntax->list #'(id2 ...))))
                 #'(id dom)]
                [(id ids dom)
                 (unless (identifier? #'id)
                   (raise-syntax-error #f "expected an identifier" stx #'id))
                 (raise-syntax-error #f "expected an sequence of identifiers" stx #'ids)]
                [_
                 (raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))])
       (list (map check-pair-shape (syntax->list #'(regular ...)))
             (map
              (λ (kwd)
                (syntax-case kwd ()
                  [(kwd ps)
                   #`(kwd #,(check-pair-shape #'ps))]))
              (syntax->list #'(kwd ...)))))]))

(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-for-syntax (find-pre/post-keywords stx)
  (let ([pre #f]
        [post #f])
    (let loop ([stx (syntax->list stx)])
      (cond
        [(syntax? stx)
         (loop (syntax-e stx))]
        [(pair? stx)
         (when (and (syntax? (car stx))
                    (eq? (syntax-e (car stx))
                         '#:pre))
           (set! pre (car stx)))
         (when (and (syntax? (car stx))
                    (eq? (syntax-e (car stx))
                         '#:post))
           (set! post (car stx)))
         (loop (cdr stx))]
        [else (void)]))
    (values pre post)))

(define-syntax (->i stx)
  (parse-->i stx)
  (printf "finished ->i parsing\n")
  (syntax-case stx ()
    [(_ (raw-mandatory-doms ...)
        .
        leftover)
     (let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)]
                  [(this->i) (gensym '->i)])
       (define (add-indy-prop stx)
         (syntax-property stx 'racket/contract:internal-contract (gensym '->i-boundary)))
       (with-syntax ([(([mandatory-regular-id mandatory-dom/no-prop] ... ) 
                       ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom/no-prop)] ...)) 
                      (verify-->i-structure stx (split-doms stx '->i #'(raw-mandatory-doms ...)))]
                     [(([optional-regular-id optional-dom/no-prop] ...)
                       ([optional-kwd (optional-kwd-id optional-kwd-dom/no-prop)] ...))
                      (verify-->i-structure stx (split-doms stx '->i raw-optional-doms))])
         (with-syntax ([(mandatory-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i))) 
                                                 (syntax->list #'(mandatory-dom/no-prop ...)))]
                       [(mandatory-kwd-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i))) 
                                                     (syntax->list #'(mandatory-kwd-dom/no-prop ...)))]
                       [(optional-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i))) 
                                                (syntax->list #'(optional-dom/no-prop ...)))]
                       [(optional-kwd-dom ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->i)) 
                                                    (syntax->list #'(optional-kwd-dom/no-prop ...)))])
         (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 ctc-pr ...)
			       (with-syntax ([((id ctc/no-prop) ...)
					      (map (lambda (x) (syntax-case x ()
								 [[id ctc/no-prop] #'[id ctc/no-prop]]
								 [[id (id2 ...) ctc/no-prop] #'[id ctc/no-prop]]
								 [x (raise-syntax-error #f "expected binding pair" stx #'x)]))
						   (syntax->list #'(ctc-pr ...)))])
					    (with-syntax ([(ctc ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:positive-position this->i)))
									  (syntax->list #'(ctc/no-prop ...)))])
							 #'((id ...) (ctc ...))))]
                              [any #'(() #f)]
                              [[id ctc] 
                               #`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
                              [[id (id2 ...) ctc] 
                               #`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
                              [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
                           [mtd? (and (syntax-parameter-value #'making-a-method) #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 '->i 
                                                 "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)) 
                      #,(syntax-property
                         #`(build-->d mtd? 
                                      (list (λ (dom-params ...)
                                              (parameterize-this this-parameter ... mandatory-dom)) ...)
                                      (list (λ (dom-params ...) 
                                              (parameterize-this this-parameter ... optional-dom)) ...)
                                      (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)))))
                         'racket/contract:contract 
                         (let-values ([(pre-kwd post-kwd) (find-pre/post-keywords #'leftover)])
                           (vector this->i 
                                   ;; the -> in the original input to this guy
                                   (let ([kwd (list (car (syntax-e stx)))])
                                     (if post-kwd
                                         (cons post-kwd kwd)
                                         kwd))
                                   (if pre-kwd
                                       (list pre-kwd)
                                       '())))))))))))))]))

(define ->d-tail-key (gensym '->d-tail-key))

(define (->d-proj ->d-stct)
  (let* ([opt-count (length (->d-optional-dom-ctcs ->d-stct))]
         [mandatory-count (+ (length (->d-mandatory-dom-ctcs ->d-stct)) 
                             (if (->d-mtd? ->d-stct) 1 0))]
         [non-kwd-ctc-count (+ mandatory-count opt-count)]
         [arity 
          (cond
            [(->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)
      (let ([this->d-id (gensym '->d-tail-key)])
        (λ (val)
          (check-procedure val
                           (->d-mtd? ->d-stct)
                           (length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
                           (length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
                           (->d-mandatory-keywords ->d-stct)
                           (->d-optional-keywords ->d-stct)
                           blame)
          (let ([kwd-proc
                 (λ (kwd-args kwd-arg-vals . raw-orig-args)
                   (let* ([orig-args (if (->d-mtd? ->d-stct)
                                         (cdr raw-orig-args)
                                         raw-orig-args)]
                          [this (and (->d-mtd? ->d-stct) (car raw-orig-args))]
                          [dep-pre-args
                           (build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct)
                                               (->d-keywords ->d-stct) kwd-args kwd-arg-vals)]
                          [thunk
                           (λ ()
                             (keyword-apply
                              val
                              kwd-args
                              
                              ;; contracted keyword arguments
                              (let loop ([all-kwds (->d-keywords ->d-stct)]
                                         [kwd-ctcs (->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) (blame-swap blame))
                                                  (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))]))
                              
                              (append
                               ;; this parameter (if necc.)
                               (if (->d-mtd? ->d-stct)
                                   (list (car raw-orig-args))
                                   '())
                               
                               ;; contracted ordinary arguments
                               (let loop ([args orig-args]
                                          [non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct)
                                                                (->d-optional-dom-ctcs ->d-stct))])
                                 (cond
                                   [(null? args) 
                                    (if (->d-rest-ctc ->d-stct)
                                        (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame))
                                        '())]
                                   [(null? non-kwd-ctcs) 
                                    (if (->d-rest-ctc ->d-stct)
                                        (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame))
                                        
                                        ;; 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) (blame-swap blame))
                                               (loop (cdr args)
                                                     (cdr non-kwd-ctcs)))])))))]
                          [rng (let ([rng (->d-range ->d-stct)])
                                 (cond
                                   [(not rng) #f]
                                   [(box? rng) 
                                    (map (λ (val) (apply val dep-pre-args))
                                         (unbox rng))]
                                   [else rng]))]
                          [rng-underscore? (box? (->d-range ->d-stct))])
                     (when (->d-pre-cond ->d-stct)
                       (unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
                         (raise-blame-error (blame-swap blame)
                                            val
                                            "#:pre violation~a"
                                            (build-values-string ", argument" dep-pre-args))))
                     (call-with-immediate-continuation-mark
                      ->d-tail-key
                      (λ (first-mark)
                        (cond
                          [(and rng
                                (not (and first-mark
                                          (eq? this->d-id (car first-mark))
                                          (andmap eq? raw-orig-args (cdr first-mark)))))
                           (call-with-values
                            (λ ()
                              (with-continuation-mark ->d-tail-key (cons this->d-id raw-orig-args)
                                (thunk)))
                            (λ orig-results
                              (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 (->d-rest-ctc ->d-stct)
                                                                        (->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
                                (when (->d-post-cond ->d-stct)
                                  (unless (apply (->d-post-cond ->d-stct) dep-post-args)
                                    (raise-blame-error blame
                                                       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
                                                     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)
                                                       blame)
                                       (loop (cdr results) (cdr result-contracts)))]))))))]
                          [else
                           (thunk)])))))])
            (make-contracted-function
             (procedure-reduce-keyword-arity
              (make-keyword-procedure kwd-proc
                                      ((->d-name-wrapper ->d-stct)
                                       (λ args
                                         (apply kwd-proc '() '() args))))
              
              arity 
              (->d-mandatory-keywords ->d-stct)
              (->d-keywords ->d-stct))
             ->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)
  (let ([ctc (coerce-contract '->d (if dep-args
                                       (apply dep-ctc dep-args)
                                       dep-ctc))])
    (((contract-projection ctc) blame) val)))

;; 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 (build-->d mtd?
                   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-->d mtd?
              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)))

;; 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 ->d (mtd?                ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
                    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) 
  
  #:omit-define-syntaxes

  #:property prop:contract
  (build-contract-property
   #:projection ->d-proj
   #:name
   (λ (ctc) 
      (let* ([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)))]))])
        `(->i (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc))
               ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc))))
              (,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc))
               ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc))))
              ,@(if (->d-rest-ctc ctc)
                  (list '#:rest (next-id) '...)
                  '())
              ,@(if (->d-pre-cond ctc)
                  (list '#:pre '...)
                  (list))
              ,(let ([range (->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 (->d-post-cond ctc)
                  (list '#:post '...)
                  (list)))))

   #:first-order (λ (ctc) (λ (x) #f))
   #:stronger (λ (this that) (eq? this that))))

