Got the first example of indy blame working
This commit is contained in:
Robby Findler
parent
9fcc157b0d
commit
599fe85a16
|
|
@ -1,13 +1,13 @@
|
|||
#lang racket/base
|
||||
(require syntax/private/boundmap
|
||||
(require (rename-in syntax/private/boundmap
|
||||
;; the private version of the library
|
||||
;; (the one without contracts)
|
||||
;; has these old, wrong names in it.
|
||||
[make-module-identifier-mapping make-free-identifier-mapping]
|
||||
[module-identifier-mapping-get free-identifier-mapping-get]
|
||||
[module-identifier-mapping-put! free-identifier-mapping-put!])
|
||||
(for-template racket/base
|
||||
"guts.rkt"))
|
||||
;; the private version of the library
|
||||
;; (the one without contracts)
|
||||
;; has these old, wrong names in it.
|
||||
(define make-free-identifier-mapping make-module-identifier-mapping)
|
||||
(define free-identifier-mapping-get module-identifier-mapping-get)
|
||||
(define free-identifier-mapping-put! module-identifier-mapping-put!)
|
||||
|
||||
#|
|
||||
|
||||
|
|
@ -54,7 +54,7 @@ code does the parsing and validation of the syntax.
|
|||
|
||||
(define (parse-->i stx)
|
||||
(let-values ([(raw-mandatory-doms raw-optional-doms
|
||||
id/rest-id pre-cond range post-cond)
|
||||
id/rest-id pre-cond range post-cond)
|
||||
(pull-out-pieces stx)])
|
||||
(let ([candidate
|
||||
(istx (append (parse-doms stx #f raw-mandatory-doms)
|
||||
|
|
|
|||
|
|
@ -6,7 +6,16 @@
|
|||
unstable/location
|
||||
(for-syntax racket/base
|
||||
racket/stxparam-exptime
|
||||
"arr-i-parse.rkt"))
|
||||
"arr-i-parse.rkt"
|
||||
|
||||
(rename-in syntax/private/boundmap
|
||||
;; the private version of the library
|
||||
;; (the one without contracts)
|
||||
;; has these old, wrong names in it.
|
||||
[make-module-identifier-mapping make-free-identifier-mapping]
|
||||
[module-identifier-mapping-get free-identifier-mapping-get]
|
||||
[module-identifier-mapping-put! free-identifier-mapping-put!]
|
||||
[module-identifier-mapping-for-each free-identifier-mapping-for-each])))
|
||||
|
||||
(provide (rename-out [->i/m ->i]))
|
||||
|
||||
|
|
@ -18,7 +27,7 @@
|
|||
;; mandatory-kwds, opt-kwds : (listof keyword?) sorted by keyword<?
|
||||
;; rest? : boolean
|
||||
;; mk-wrapper : creates the a wrapper function that implements the contract checking
|
||||
(struct ->i (arg-ctcs indy-arg-ctcs arg-dep-ctcs rng-ctcs indy-rng-ctcs rng-dep-ctcs mandatory-args opt-args mandatory-kwds opt-kwds rest? mk-wrapper)
|
||||
(struct ->i (arg-ctcs indy-arg-ctcs arg-dep-ctcs rng-ctcs indy-rng-ctcs rng-dep-ctcs mandatory-args opt-args mandatory-kwds opt-kwds rest? here mk-wrapper)
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection
|
||||
|
|
@ -28,36 +37,35 @@
|
|||
[rng-ctc-projs (map contract-projection (->i-rng-ctcs ctc))]
|
||||
[indy-rng-ctc-projs (map contract-projection (->i-indy-rng-ctcs ctc))]
|
||||
[func (->i-mk-wrapper ctc)]
|
||||
[has-rest? (->i-rest? ctc)])
|
||||
[has-rest? (->i-rest? ctc)]
|
||||
[here (->i-here ctc)])
|
||||
(λ (blame)
|
||||
(let* ([swapped-blame (blame-swap blame)]
|
||||
[here (quote-module-path)]
|
||||
[indy-dom-blame (blame-replace-negative swapped-blame here)]
|
||||
[indy-rng-blame (blame-replace-negative blame here)])
|
||||
(let ([partial-doms (map (λ (dom) (dom swapped-blame)) arg-ctc-projs)]
|
||||
[partial-indy-doms (map (λ (dom) (dom indy-dom-blame)) indy-arg-ctc-projs)]
|
||||
[partial-rngs (map (λ (rng) (rng blame)) rng-ctc-projs)]
|
||||
[partial-indy-rngs (map (λ (rng) (rng indy-rng-blame)) rng-ctc-projs)])
|
||||
(printf "partial-doms ~s partial-indy-doms ~s\n" partial-doms partial-indy-doms)
|
||||
(apply func
|
||||
blame
|
||||
swapped-blame
|
||||
indy-dom-blame
|
||||
indy-rng-blame
|
||||
(λ (val mtd?)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? (->i-mandatory-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame)
|
||||
(check-procedure val mtd? (->i-mandatory-args ctc) (->i-opt-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame)))
|
||||
ctc
|
||||
(append partial-doms
|
||||
partial-indy-doms
|
||||
(->i-arg-dep-ctcs ctc)
|
||||
partial-rngs
|
||||
partial-indy-rngs
|
||||
(->i-rng-dep-ctcs ctc))))))))
|
||||
#:name (λ (ctc) '->i)
|
||||
#:first-order (λ (ctc) (λ (x) #f))
|
||||
#:stronger (λ (this that) #f)))
|
||||
[indy-rng-blame (blame-replace-negative blame here)]
|
||||
[partial-doms (map (λ (dom) (dom swapped-blame)) arg-ctc-projs)]
|
||||
[partial-indy-doms (map (λ (dom) (dom indy-dom-blame)) indy-arg-ctc-projs)]
|
||||
[partial-rngs (map (λ (rng) (rng blame)) rng-ctc-projs)]
|
||||
[partial-indy-rngs (map (λ (rng) (rng indy-rng-blame)) rng-ctc-projs)])
|
||||
(apply func
|
||||
blame
|
||||
swapped-blame
|
||||
indy-dom-blame
|
||||
indy-rng-blame
|
||||
(λ (val mtd?)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? (->i-mandatory-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame)
|
||||
(check-procedure val mtd? (->i-mandatory-args ctc) (->i-opt-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame)))
|
||||
ctc
|
||||
(append partial-doms
|
||||
(->i-arg-dep-ctcs ctc)
|
||||
partial-indy-doms
|
||||
partial-rngs
|
||||
(->i-rng-dep-ctcs ctc)
|
||||
partial-indy-rngs))))))
|
||||
#:name (λ (ctc) '->i) ;; WRONG
|
||||
#:first-order (λ (ctc) (λ (x) #f)) ;; WRONG
|
||||
#:stronger (λ (this that) #f))) ;; WRONG
|
||||
|
||||
;; find-ordering : (listof arg) -> (listof (cons number arg))
|
||||
(define-for-syntax (find-ordering args)
|
||||
|
|
@ -147,15 +155,20 @@
|
|||
(cons (car kwd-args) args-rec))]))]))])
|
||||
(keyword-apply fn kwds kwd-args (filter (λ (x) (not (eq? x the-unsupplied-arg))) args))))
|
||||
|
||||
(define-for-syntax (maybe-generate-temporary x)
|
||||
(and x (car (generate-temporaries (list x)))))
|
||||
|
||||
(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))))]
|
||||
[indy-arg-proj-vars (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))])
|
||||
|
||||
(printf "arg-proj-vars ~s indy-arg-proj-vars ~s\n" arg-proj-vars indy-arg-proj-vars)
|
||||
|
||||
;; WRONG: need to remove unused indy projections
|
||||
;; this list is parallel to arg-proj-vars (so use arg-indicies to find the right ones in the loop below)
|
||||
;; but it contains #fs in places where we don't need the indy projections
|
||||
[indy-arg-proj-vars (list->vector (map maybe-generate-temporary (map (λ (x) (and (not (arg-vars x)) (arg-var x))) (istx-args an-istx))))])
|
||||
|
||||
(define (arg-to-indy-var var)
|
||||
(let loop ([iargs indy-args]
|
||||
|
|
@ -169,7 +182,14 @@
|
|||
(cond
|
||||
[(free-identifier=? var arg) iarg]
|
||||
[else (loop (cdr iargs) (cdr args))]))])))
|
||||
#`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc #,@(vector->list arg-proj-vars) #,@(vector->list indy-arg-proj-vars))
|
||||
|
||||
#`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc
|
||||
;; first the non-dependent arg projections
|
||||
#,@(filter values (map (λ (arg arg-proj-var) (and (not (arg-vars arg)) arg-proj-var)) (istx-args an-istx) (vector->list arg-proj-vars)))
|
||||
;; then the dependent arg projections
|
||||
#,@(filter values (map (λ (arg arg-proj-var) (and (arg-vars arg) arg-proj-var)) (istx-args an-istx) (vector->list arg-proj-vars)))
|
||||
;; then the non-dependent indy projections
|
||||
#,@(filter values (vector->list indy-arg-proj-vars)))
|
||||
(λ (val)
|
||||
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
|
||||
(make-contracted-function
|
||||
|
|
@ -177,7 +197,8 @@
|
|||
#,(for/fold ([body (args/vars->callsite #'val (istx-args an-istx) wrapper-args)])
|
||||
([indy-arg (in-list indy-args)]
|
||||
[arg (in-list ordered-args)]
|
||||
[arg-index arg-indicies])
|
||||
[arg-index arg-indicies]
|
||||
[i (in-naturals)])
|
||||
(let ([wrapper-arg (vector-ref wrapper-args arg-index)]
|
||||
[arg-proj-var (vector-ref arg-proj-vars arg-index)]
|
||||
[indy-arg-proj-var (vector-ref indy-arg-proj-vars arg-index)])
|
||||
|
|
@ -193,7 +214,6 @@
|
|||
#,(add-unsupplied-check
|
||||
(if (arg-vars arg)
|
||||
#`(un-dep (#,arg-proj-var #,@(map arg-to-indy-var (arg-vars arg))) #,wrapper-arg indy-dom-blame)
|
||||
;; WRONG! (need to pass in the indy'ized projections somewhere)
|
||||
#`(#,indy-arg-proj-var #,wrapper-arg)))]
|
||||
[#,wrapper-arg
|
||||
#,(add-unsupplied-check
|
||||
|
|
@ -204,14 +224,28 @@
|
|||
ctc))))))
|
||||
|
||||
(define (un-dep ctc obj blame)
|
||||
(printf "un-dep blame ~s\n" blame)
|
||||
;; WRONG (well, just need to avoid calling coerce-contract if 'ctc' is something simple)
|
||||
;; 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-for-syntax (used-indy-vars an-istx)
|
||||
(let ([vars (make-free-identifier-mapping)])
|
||||
(for ([an-arg (in-list (istx-args an-istx))])
|
||||
(when (arg-vars an-arg)
|
||||
(for ([var (in-list (arg-vars an-arg))])
|
||||
(free-identifier-mapping-put! vars var #t))))
|
||||
(when (istx-ress an-istx)
|
||||
(for ([a-res (in-list (istx-ress an-istx))])
|
||||
(when (res-vars a-res)
|
||||
(for ([var (in-list (res-vars a-res))])
|
||||
(free-identifier-mapping-put! vars var #t)))))
|
||||
vars))
|
||||
|
||||
(define-syntax (->i/m stx)
|
||||
(let* ([an-istx (parse-->i stx)]
|
||||
[used-indy-vars (used-indy-vars an-istx)]
|
||||
[wrapper-func (mk-wrapper-func an-istx)])
|
||||
;(printf "used-indy-vars:") (free-identifier-mapping-for-each used-indy-vars (λ (x y) (printf " ~a" x))) (printf "\n")
|
||||
#`(->i (list #,@(filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-ctc arg)))
|
||||
(istx-args an-istx))))
|
||||
;; WRONG! this needs to be a subset of the previous list (and to generate a let to share appropriately)
|
||||
|
|
@ -245,4 +279,5 @@
|
|||
(istx-args an-istx)))
|
||||
keyword<?)
|
||||
#,(and (istx-rst an-istx) #t)
|
||||
(quote-module-path)
|
||||
#,wrapper-func)))
|
||||
|
|
|
|||
|
|
@ -3,15 +3,15 @@
|
|||
racket/pretty)
|
||||
|
||||
(pretty-print
|
||||
(syntax->datum (expand
|
||||
(syntax->datum (expand-once
|
||||
#'(->i ([f (-> number? number?)]
|
||||
[y (f) (<=/c (f 0))])
|
||||
[y (f) (<=/c (begin (printf "f: ~s\n" f) (f 'not-a-number)))])
|
||||
any))))
|
||||
|
||||
((contract (->i ([f (-> number? number?)]
|
||||
[y (f) (<=/c (f 'not-a-number))])
|
||||
[y (f) (<=/c (begin (printf "f: ~s\n" f) (f 'not-a-number)))])
|
||||
any)
|
||||
(λ (f y) 'final-result)
|
||||
(λ (f y) (f 'another-non-number) 'final-result)
|
||||
'pos 'neg)
|
||||
(λ (x) (* x x))
|
||||
-10)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user