diff --git a/collects/racket/contract/private/arr-i-parse.rkt b/collects/racket/contract/private/arr-i-parse.rkt index 2a7241f31d..8c3f3b5811 100644 --- a/collects/racket/contract/private/arr-i-parse.rkt +++ b/collects/racket/contract/private/arr-i-parse.rkt @@ -12,19 +12,20 @@ #| The ->i contract first parses its input into an istx struct -and then operates on it to generate the expanded form +and then operates on it to generate the expanded form. This +code does the parsing and validation of the syntax. |# ;; args : (listof arg?) -;; rest : (or/c #f rst?) +;; rst : (or/c #f rst?) ;; pre : (or/c stx[expr] #f) ;; ress : (or/c #f (listof eres?) (listof lres?)) ;; post : (or/c stx[expr] #f) (struct istx (args rst pre ress post)) ;; NOTE: the ress field may contain a mixture of eres and lres structs -;; but only temporarily; after it is constructed, a syntax error -;; is signalled and the istx struct is not used afterwards +;; but only temporarily; in that case, a syntax error +;; is signaled and the istx struct is not used afterwards ;; kwd : (or/c #f syntax[kwd]) diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index e69de29bb2..3a7bc05584 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -0,0 +1,135 @@ +#lang racket/base + +(require "arrow.rkt" + "prop.rkt" + "guts.rkt" + (for-syntax racket/base + racket/stxparam-exptime + "arr-i-parse.rkt")) + +(provide (rename-out [->i/m ->i])) + +;; arg-ctcs : (listof contract) +;; arg-dep-ctcs : (-> ??? (listof contract)) +;; rng-ctcs : (listof contract) +;; rng-dep-ctcs : (-> ??? (listof contract)) +;; mandatory-args, opt-args : number +;; mandatory-kwds, opt-kwds : (listof keyword?) sorted by keywordi (arg-ctcs arg-dep-ctcs rng-ctcs rng-dep-ctcs mandatory-args opt-args mandatory-kwds opt-kwds rest? mk-wrapper) + #:property prop:contract + (build-contract-property + #:projection + (λ (ctc) + (let ([arg-ctc-projs (map contract-projection (->i-arg-ctcs ctc))] + [rng-ctc-projs (map contract-projection (->i-rng-ctcs ctc))] + [func (->i-mk-wrapper ctc)] + [has-rest? (->i-rest? ctc)]) + (λ (blame) + (let ([swapped-blame (blame-swap blame)] + [indy-blame blame]) ;; WRONG! + (let ([partial-doms (map (λ (dom) (dom swapped-blame)) arg-ctc-projs)] + [partial-rngs (map (λ (rng) (rng blame)) rng-ctc-projs)]) + (apply func + blame + swapped-blame + indy-blame + (λ (val mtd?) + ' ;; WRONG! + (if has-rest? + (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame) + (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame))) + ctc + (append partial-doms + (->i-arg-dep-ctcs ctc) + partial-rngs + (->i-rng-dep-ctcs ctc)))))))) + #:name (λ (ctc) '->i) + #:first-order (λ (ctc) (λ (x) #f)) + #:stronger (λ (this that) #f))) + +;; find-ordering : (listof arg) -> (listof (cons number arg)) +(define-for-syntax (find-ordering args) + (values (reverse args) + (reverse + (for/list ([arg (in-list args)] + [i (in-naturals)]) + i)))) + +(define-for-syntax (mk-wrapper-func an-istx) + (let-values ([(ordered-args arg-indicies) (find-ordering (istx-args an-istx))]) + + (let ([wrapper-args (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))] + [indy-args (generate-temporaries (map arg-var ordered-args))] + [arg-proj-vars (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))]) + + (define (arg-to-indy-var var) + (let loop ([iargs indy-args] + [args (map arg-var ordered-args)]) + (cond + [(null? args) + (error '->i "internal error; did not find a matching var for ~s" var)] + [else + (let ([arg (car args)] + [iarg (car iargs)]) + (cond + [(free-identifier=? var arg) iarg] + [else (loop (cdr iargs) (cdr args))]))]))) + + #`(λ (blame swapped-blame indy-blame chk ctc #,@(vector->list arg-proj-vars)) + (λ (val) + (chk val #,(and (syntax-parameter-value #'making-a-method) #t)) + (make-contracted-function + (λ #,(vector->list wrapper-args) + #,(for/fold ([body #`(val #,@(vector->list wrapper-args))]) + ([indy-arg (in-list indy-args)] + [arg (in-list ordered-args)] + [arg-index arg-indicies]) + (let ([wrapper-arg (vector-ref wrapper-args arg-index)] + [arg-proj-var (vector-ref arg-proj-vars arg-index)]) + #`(let ([#,indy-arg #,(if (arg-vars arg) + #`(un-dep (#,arg-proj-var #,@(map arg-to-indy-var (arg-vars arg))) #,wrapper-arg indy-blame) + ;; WRONG! (need to pass in the indy'ized projections somewhere) + #`(#,arg-proj-var #,wrapper-arg))] + [#,wrapper-arg + #,(if (arg-vars arg) + #`(un-dep (#,arg-proj-var #,@(map arg-to-indy-var (arg-vars arg))) #,wrapper-arg swapped-blame) + #`(#,arg-proj-var #,wrapper-arg))]) + #,body)))) + ctc)))))) + +(define (un-dep ctc obj blame) + ;; WRONG (well, just need to avoid calling coerce-contract if 'ctc' is something simple) + (let ([ctc (coerce-contract '->i ctc)]) + (((contract-projection ctc) blame) obj))) + +(define-syntax (->i/m stx) + (let* ([an-istx (parse-->i stx)] + [wrapper-func (mk-wrapper-func an-istx)]) + #`(->i (list #,@(filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-ctc arg))) + (istx-args an-istx)))) + (list #,@(filter values (map (λ (arg) (and (arg-vars arg) #`(λ #,(arg-vars arg) #,(arg-ctc arg)))) + (istx-args an-istx)))) + + #,(if (istx-ress an-istx) + #`(list #,@(filter values (map (λ (arg) (and (not (res-vars arg)) (res-ctc arg))) + (istx-ress an-istx)))) + #''()) + #,(if (istx-ress an-istx) + #`(list #,@(filter values (map (λ (arg) (and (res-vars arg) #`(λ #,(res-vars arg) #,(res-ctc arg)))) + (istx-ress an-istx)))) + #''()) + + #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (not (arg-optional? arg)))) + (istx-args an-istx)))) + #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (arg-optional? arg))) + (istx-args an-istx)))) + '#,(sort (filter values (map (λ (arg) (and (not (arg-optional? arg)) (arg-kwd arg))) + (istx-args an-istx))) + keyword-dom-rest/c ctc) - (append (->-doms/c ctc) (list (->-dom-rest/c ctc))) - (->-doms/c ctc)))] - [doms-optional-proj (map contract-projection (->-optional-doms/c ctc))] - [rngs-proj (map contract-projection (->-rngs/c ctc))] - [mandatory-kwds-proj (map contract-projection (->-mandatory-kwds/c ctc))] - [optional-kwds-proj (map contract-projection (->-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)]) - (λ (blame) - (let ([partial-doms (map (λ (dom) (dom (blame-swap blame))) - doms-proj)] - [partial-optional-doms (map (λ (dom) (dom (blame-swap blame))) - doms-optional-proj)] - [partial-ranges (map (λ (rng) (rng blame)) - rngs-proj)] - [partial-mandatory-kwds (map (λ (kwd) (kwd (blame-swap blame))) - mandatory-kwds-proj)] - [partial-optional-kwds (map (λ (kwd) (kwd (blame-swap blame))) - optional-kwds-proj)]) + (let* ([doms-proj (map contract-projection + (if (->-dom-rest/c ctc) + (append (->-doms/c ctc) (list (->-dom-rest/c ctc))) + (->-doms/c ctc)))] + [doms-optional-proj (map contract-projection (->-optional-doms/c ctc))] + [rngs-proj (map contract-projection (->-rngs/c ctc))] + [mandatory-kwds-proj (map contract-projection (->-mandatory-kwds/c ctc))] + [optional-kwds-proj (map contract-projection (->-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)]) + (λ (blame) + (let ([swapped (blame-swap blame)]) + (let ([partial-doms (map (λ (dom) (dom swapped)) doms-proj)] + [partial-optional-doms (map (λ (dom) (dom swapped)) doms-optional-proj)] + [partial-ranges (map (λ (rng) (rng blame)) rngs-proj)] + [partial-mandatory-kwds (map (λ (kwd) (kwd swapped)) mandatory-kwds-proj)] + [partial-optional-kwds (map (λ (kwd) (kwd swapped)) optional-kwds-proj)]) (apply func (λ (val mtd?) (if has-rest? @@ -153,7 +149,7 @@ v4 todo: ctc (append partial-doms partial-optional-doms partial-mandatory-kwds partial-optional-kwds - partial-ranges)))))) + partial-ranges))))))) #:name (λ (ctc) (single-arrow-name-maker diff --git a/collects/racket/contract/scratch.rkt b/collects/racket/contract/scratch.rkt index 5220a0b8a7..ea3a77aa72 100644 --- a/collects/racket/contract/scratch.rkt +++ b/collects/racket/contract/scratch.rkt @@ -1,10 +1,18 @@ #lang racket/base -(require racket/contract) +(require racket/contract + racket/pretty) +(pretty-print + (syntax->datum (expand + #'(->i (#:x [x number?] + [y (x) (<=/c x)]) + any)))) -#; -(->i ([x number?] - [y (x) (<=/c x)]) - any) +((contract (->i (#:x [x number?] + [y (x) (<=/c x)]) + any) + (λ (x y) x) + 'pos 'neg) + 2 1) #; (define (coerce-proj x) @@ -42,7 +50,7 @@ [yi (y/proc xi here pos blame info)]) (f x y))))))) -(syntax->datum (expand #'(-> number? (<=/c 10) any))) +;(pretty-print (syntax->datum (expand #'(-> number? (<=/c 10) any))))