From f5a190bf804d40d1861bd1cb94eddedb44d6852d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 12 Jul 2010 16:26:05 -0500 Subject: [PATCH] made a copy of the ->d contract implementation as a starting point for an implementation of ->i (sometimes, paper deadlines can be a Bad Thing...) --- collects/racket/contract/base.rkt | 5 +- collects/racket/contract/private/arr-i.rkt | 528 ++++++++++++++++++ collects/racket/contract/private/arr-util.rkt | 61 ++ collects/racket/contract/private/arrow.rkt | 67 +-- 4 files changed, 599 insertions(+), 62 deletions(-) create mode 100644 collects/racket/contract/private/arr-i.rkt create mode 100644 collects/racket/contract/private/arr-util.rkt diff --git a/collects/racket/contract/base.rkt b/collects/racket/contract/base.rkt index 6176ef85ff..4503211cdd 100644 --- a/collects/racket/contract/base.rkt +++ b/collects/racket/contract/base.rkt @@ -4,6 +4,7 @@ ;; the PLT code base where appropriate. (require "private/arrow.rkt" + "private/arr-i.rkt" "private/base.rkt" "private/misc.rkt" "private/provide.rkt" @@ -21,7 +22,9 @@ making-a-method procedure-accepts-and-more? check-procedure - check-procedure/more) + check-procedure/more + make-contracted-function) + (all-from-out "private/arr-i.rkt") (except-out (all-from-out "private/misc.rkt") check-between/c check-unary-between/c) diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt new file mode 100644 index 0000000000..a473140534 --- /dev/null +++ b/collects/racket/contract/private/arr-i.rkt @@ -0,0 +1,528 @@ +#lang racket/base + +(require "guts.rkt" + "arrow.rkt" + "opt.rkt" + racket/stxparam) +(require (for-syntax racket/base) + (for-syntax "opt-guts.rkt") + (for-syntax "helpers.rkt") + (for-syntax syntax/stx) + (for-syntax syntax/name) + (for-syntax "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-cond expr) + (values '() leftover)] + [((opts ...) . rest) + (values #'(opts ...) #'rest)] + [_ (values '() leftover)])] + [(id/rest-id leftover) + (syntax-case leftover () + [(#:rest id rest-expr . leftover) + (and (identifier? #'id) + (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-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-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 (->i stx) + (syntax-case stx () + [(_ (raw-mandatory-doms ...) + . + leftover) + (let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)]) + (with-syntax ([(([mandatory-regular-id mandatory-doms] ... ) ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom)] ...)) + (verify-->d-structure stx (split-doms stx '->d #'(raw-mandatory-doms ...)))] + [(([optional-regular-id optional-doms] ... ) ([optional-kwd (optional-kwd-id optional-kwd-dom)] ...)) + (verify-->d-structure stx (split-doms stx '->d raw-optional-doms))]) + (with-syntax ([((kwd kwd-id) ...) + (sort-keywords + stx + (syntax->list + #'((optional-kwd optional-kwd-id) ... + (mandatory-kwd mandatory-kwd-id) ...)))] + [(this-parameter ...) + (make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method)) + (car (generate-temporaries '(this))) + (datum->syntax stx 'this #f)))]) + (with-syntax ([(dom-params ...) + #`(this-parameter ... + mandatory-regular-id ... + 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)]) + (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? + (list (λ (dom-params ...) + (parameterize-this this-parameter ... mandatory-doms)) ...) + (list (λ (dom-params ...) + (parameterize-this this-parameter ... optional-doms)) ...) + (list (λ (dom-params ...) + (parameterize-this this-parameter ... mandatory-kwd-dom)) ...) + (list (λ (dom-params ...) + (parameterize-this this-parameter ... optional-kwd-dom)) ...) + #,(if id/rest + (with-syntax ([(id rst-ctc) id/rest]) + #`(λ (dom-params ...) + (parameterize-this this-parameter ... rst-ctc))) + #f) + #,(if pre-cond + #`(λ (dom-params ...) + (parameterize-this this-parameter ... #,pre-cond)) + #f) + #,(syntax-case #'rng-ctcs () + [#f #f] + [(ctc ...) + (if rng-underscores? + #'(box (list (λ (dom-params ...) + (parameterize-this this-parameter ... ctc)) ...)) + #'(list (λ (rng-params ... dom-params ...) + (parameterize-this this-parameter ... ctc)) ...))]) + #,(if post-cond + #`(λ (rng-params ... dom-params ...) + (parameterize-this this-parameter ... #,post-cond)) + #f) + '(mandatory-kwd ...) + '(optional-kwd ...) + (λ (f) + #,(add-name-prop + (syntax-local-infer-name stx) + #`(λ args (apply f args)))))))))))))])) + +(define ->d-tail-key (gensym '->d-tail-key)) + +(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-cond 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-cond 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) (keywordd 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)))]))]) + `(->d (,@(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-cond '...) + (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-cond '...) + (list))))) + + #:first-order (λ (ctc) (λ (x) #f)) + #:stronger (λ (this that) (eq? this that)))) + diff --git a/collects/racket/contract/private/arr-util.rkt b/collects/racket/contract/private/arr-util.rkt new file mode 100644 index 0000000000..25b6982b41 --- /dev/null +++ b/collects/racket/contract/private/arr-util.rkt @@ -0,0 +1,61 @@ +#lang racket/base + +(provide split-doms + sort-keywords) + +;; split-doms : syntax identifier syntax -> syntax +;; given a sequence of keywords interpersed with other +;; stuff, splits out the keywords and sorts them, +;; and leaves the rest of the stuff in a row. +(define (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 + "cannot have two keywords in a row" + stx + #'kwd)] + [(kwd) + (keyword? (syntax-e #'kwd)) + (raise-syntax-error name + "cannot have a keyword at the end" + stx + #'kwd)] + [(x . rest) + (loop #'rest (cons #'x doms) kwd-doms)]))) + +;; sort-keywords : syntax (listof syntax[(kwd . whatever)] -> (listof syntax[(kwd . whatever)]) +;; sorts a list of syntax according to the keywords in the list +(define (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 ->* @@ -36,13 +37,14 @@ v4 todo: making-a-method procedure-accepts-and-more? check-procedure - check-procedure/more) + check-procedure/more + make-contracted-function) (define-syntax-parameter making-a-method #f) (define-for-syntax (make-this-parameters id) (if (syntax-parameter-value #'making-a-method) - (list id) - null)) + (list id) + null)) (define-struct contracted-function (proc ctc) #:property prop:procedure 0 @@ -234,63 +236,6 @@ v4 todo: (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 syntax -;; given a sequence of keywords interpersed with other -;; stuff, splits out the keywords and sorts them, -;; and leaves the rest of the stuff in a row. -(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 - "cannot have two keywords in a row" - stx - #'kwd)] - [(kwd) - (keyword? (syntax-e #'kwd)) - (raise-syntax-error name - "cannot have a keyword at the end" - stx - #'kwd)] - [(x . rest) - (loop #'rest (cons #'x doms) kwd-doms)]))) - (define-for-syntax (->-helper stx) (syntax-case stx () [(-> raw-doms ... last-one)