Made reasons get passed through and re-add a failing test.
original commit: 62f4aec04f91d0740101bc01fc12118a56ac44a6
This commit is contained in:
Eric Dobson
parent
a021ecf313
commit
9525b658d1
|
|
@ -26,7 +26,8 @@
|
|||
(provide
|
||||
(c:contract-out
|
||||
[type->static-contract
|
||||
(c:parametric->/c (a) ((Type/c (c:-> a)) (#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))]))
|
||||
(c:parametric->/c (a) ((Type/c (c:-> #:reason (c:or/c #f string?) a))
|
||||
(#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))]))
|
||||
|
||||
(provide type->contract define/fixup-contract? change-contract-fixups
|
||||
type->contract-fail)
|
||||
|
|
@ -152,7 +153,7 @@
|
|||
|
||||
(define (type->contract ty init-fail #:typed-side [typed-side #t] #:kind [kind 'impersonator])
|
||||
(let/ec escape
|
||||
(define (fail) (escape (init-fail)))
|
||||
(define (fail #:reason [reason #f]) (escape (init-fail #:reason reason)))
|
||||
(instantiate
|
||||
(optimize
|
||||
(type->static-contract ty #:typed-side typed-side fail)
|
||||
|
|
@ -181,7 +182,7 @@
|
|||
|
||||
(define (type->static-contract type init-fail #:typed-side [typed-side #t])
|
||||
(let/ec return
|
||||
(define (fail) (return (init-fail)))
|
||||
(define (fail #:reason reason) (return (init-fail #:reason reason)))
|
||||
(let loop ([type type] [typed-side (if typed-side 'typed 'untyped)] [recursive-values (hash)])
|
||||
(define (t->sc t #:recursive-values (recursive-values recursive-values))
|
||||
(loop t typed-side recursive-values))
|
||||
|
|
@ -244,7 +245,7 @@
|
|||
[(PolyDots: _ body) (loop body)]
|
||||
[_ #f])))
|
||||
(unless function-type?
|
||||
(fail))
|
||||
(fail #:reason "cannot generate contract for non-function polymorphic type"))
|
||||
(let ((temporaries (generate-temporaries vs-nm)))
|
||||
(define rv (for/fold ((rv recursive-values)) ((temp temporaries)
|
||||
(v-nm vs-nm))
|
||||
|
|
@ -287,7 +288,7 @@
|
|||
[(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred?)
|
||||
(cond
|
||||
[(dict-ref recursive-values nm #f)]
|
||||
[proc (fail)]
|
||||
[proc (fail #:reason "t->sc2")]
|
||||
[poly?
|
||||
(define nm* (generate-temporary #'n*))
|
||||
(define fields
|
||||
|
|
@ -310,7 +311,7 @@
|
|||
[(Channel: t)
|
||||
(channel/sc (t->sc t))]
|
||||
[else
|
||||
(fail)]))))
|
||||
(fail #:reason "t->sc3")]))))
|
||||
|
||||
(define (t->sc/function f fail typed-side recursive-values loop method?)
|
||||
(define (t->sc t #:recursive-values (recursive-values recursive-values))
|
||||
|
|
@ -378,7 +379,7 @@
|
|||
(let-values ([(mand-kws opt-kws) (partition-kws kws)])
|
||||
;; Garr, I hate case->!
|
||||
(when (and (not (empty? kws)) case->)
|
||||
(fail))
|
||||
(fail #:reason "t->sc4"))
|
||||
(if case->
|
||||
(arr/sc (map t->sc/neg dom) (and rst (t->sc/neg rst)) (map t->sc rngs))
|
||||
(function/sc
|
||||
|
|
@ -395,15 +396,15 @@
|
|||
;; functions with filters or objects
|
||||
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f kws)
|
||||
(if (from-untyped? typed-side)
|
||||
(fail)
|
||||
(fail #:reason "t->sc5")
|
||||
(convert-arr a))]
|
||||
[_ (fail)]))
|
||||
[_ (fail #:reason "t->sc6")]))
|
||||
(unless (no-duplicates (for/list ([t arrs])
|
||||
(match t
|
||||
[(arr: dom _ _ _ _) (length dom)]
|
||||
;; is there something more sensible here?
|
||||
[(top-arr:) (int-err "got top-arr")])))
|
||||
(fail))
|
||||
(fail #:reason "t->sc7"))
|
||||
(if (= (length arrs) 1)
|
||||
((f #f) (first arrs))
|
||||
(case->/sc (map (f #t) arrs)))])]
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@
|
|||
(merge-restricts*
|
||||
(if mut? 'chaperone 'flat)
|
||||
(map (lambda (a) (if mut?
|
||||
(add-constraint (f a) 'chaperone)
|
||||
(add-constraint (f a) 'chaperone "reason3")
|
||||
(f a)))
|
||||
args))]))])
|
||||
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@
|
|||
#'(lambda (v recur)
|
||||
(for/list ([arg (in-list (combinator-args v))]
|
||||
[kind (in-list (list 'pos.category-stx ...))])
|
||||
(add-constraint (recur arg) kind)))
|
||||
(add-constraint (recur arg) kind "reason1")))
|
||||
#:attr combinator2
|
||||
#'(λ (constructor) (λ (pos.name ...) (constructor (list pos.name ...))))
|
||||
#:with matcher
|
||||
|
|
@ -73,7 +73,7 @@
|
|||
#:with ->restricts
|
||||
#'(lambda (v recur)
|
||||
(for/list ([arg (in-list (combinator-args v))])
|
||||
(add-constraint (recur arg) 'rest.category-stx)))
|
||||
(add-constraint (recur arg) 'rest.category-stx "reason2")))
|
||||
#:with matcher
|
||||
#'(define-match-expander matcher-name
|
||||
(syntax-parser
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@
|
|||
;; This means that the generated contract will be the max of kind and all of the other contract
|
||||
;; restricts.
|
||||
;;
|
||||
;; add-constraint: contract-restrict? kind? -> contract-restrict
|
||||
;; add-constraint: contract-restrict? kind? string? -> contract-restrict
|
||||
;; This means the kind of the generated contract can not be greater than the supplied kind.
|
||||
;;
|
||||
;; close-loop: (lisotf identifier?) (listof contract-restrict?) contract-restrict? -> contract-restrict?
|
||||
|
|
@ -50,11 +50,12 @@
|
|||
variable-contract-restrict
|
||||
merge-restricts*
|
||||
merge-restricts
|
||||
add-constraint
|
||||
close-loop
|
||||
(contract-out
|
||||
[exn:fail:constraint-failure? predicate/c]
|
||||
[validate-constraints (contract-restrict? . -> . void?)])
|
||||
[exn:fail:constraint-failure-reason (exn:fail:constraint-failure? . -> . string?)]
|
||||
[validate-constraints (contract-restrict? . -> . void?)]
|
||||
[add-constraint (contract-restrict? contract-kind? string? . -> . contract-restrict?)])
|
||||
contract-restrict-recursive-values
|
||||
|
||||
contract-restrict?
|
||||
|
|
@ -67,19 +68,19 @@
|
|||
"kinds.rkt")
|
||||
(provide
|
||||
(contract-out
|
||||
[struct constraint ([value kind-max?] [max contract-kind?])]
|
||||
[struct constraint ([value kind-max?] [max contract-kind?] [reason string?])]
|
||||
[struct kind-max ([variables free-id-table?] [max contract-kind?])]
|
||||
[struct contract-restrict ([value kind-max?]
|
||||
[recursive-values free-id-table?]
|
||||
[constraints (set/c constraint?)])]))
|
||||
|
||||
(struct constraint (value max) #:transparent)
|
||||
(struct constraint (value max reason) #:transparent)
|
||||
(struct kind-max (variables max) #:transparent)
|
||||
(struct contract-restrict (value recursive-values constraints) #:transparent))
|
||||
(require 'structs)
|
||||
(provide (struct-out kind-max))
|
||||
|
||||
(struct exn:fail:constraint-failure exn:fail ())
|
||||
(struct exn:fail:constraint-failure exn:fail (reason))
|
||||
|
||||
(define (free-id-set . elems)
|
||||
(for/fold ([table (make-immutable-free-id-table)])
|
||||
|
|
@ -104,12 +105,12 @@
|
|||
(contract-restrict (kind-max (free-id-set var) 'flat) (make-immutable-free-id-table) (set)))
|
||||
|
||||
|
||||
(define (add-constraint cr max)
|
||||
(define (add-constraint cr max reason)
|
||||
(if (equal? 'impersonator max)
|
||||
cr
|
||||
(match cr
|
||||
[(contract-restrict v rec constraints)
|
||||
(contract-restrict v rec (set-add constraints (constraint v max)))])))
|
||||
(contract-restrict v rec (set-add constraints (constraint v max reason)))])))
|
||||
|
||||
(define (add-recursive-values cr dict)
|
||||
(match cr
|
||||
|
|
@ -180,7 +181,10 @@
|
|||
[(contract-restrict (kind-max (app dict-count 0) _) rec constraints)
|
||||
(for ([const (in-set constraints)])
|
||||
(match const
|
||||
[(constraint (kind-max (app dict-count 0) kind) bound)
|
||||
[(constraint (kind-max (app dict-count 0) kind) bound reason)
|
||||
(unless (contract-kind<= kind bound)
|
||||
(raise (exn:fail:constraint-failure "Violated constraint ~a" (current-continuation-marks))))]))]))
|
||||
(raise (exn:fail:constraint-failure
|
||||
(format "Violated constraint: ~a" reason)
|
||||
(current-continuation-marks)
|
||||
reason)))]))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,9 @@
|
|||
|
||||
(provide
|
||||
(c:contract-out
|
||||
[instantiate ((static-contract? (c:-> c:none/c)) (contract-kind?) . c:->* . syntax?)]))
|
||||
[instantiate
|
||||
(c:parametric->/c (a) ((static-contract? (c:-> #:reason (c:or/c #f string?) a))
|
||||
(contract-kind?) . c:->* . (c:or/c a syntax?)))]))
|
||||
|
||||
;; Providing these so that tests can work directly with them.
|
||||
(module* internals #f
|
||||
|
|
@ -27,7 +29,8 @@
|
|||
;; kind is the greatest kind of contract that is supported, if a greater kind would be produced the
|
||||
;; fail procedure is called.
|
||||
(define (instantiate sc fail [kind 'impersonator])
|
||||
(with-handlers [(exn:fail:constraint-failure? (lambda (exn) (fail)))]
|
||||
(with-handlers [(exn:fail:constraint-failure?
|
||||
(lambda (exn) (fail #:reason (exn:fail:constraint-failure-reason exn))))]
|
||||
(instantiate/inner sc
|
||||
(compute-recursive-kinds
|
||||
(contract-restrict-recursive-values (compute-constraints sc kind))))))
|
||||
|
|
@ -40,7 +43,7 @@
|
|||
[(? sc?)
|
||||
(sc->constraints sc recur)]))
|
||||
(define constraints (recur sc))
|
||||
(validate-constraints (add-constraint constraints max-kind))
|
||||
(validate-constraints (add-constraint constraints max-kind "reason4"))
|
||||
constraints)
|
||||
|
||||
|
||||
|
|
@ -64,7 +67,7 @@
|
|||
(for/hash (((name var) vars))
|
||||
(values name (hash-ref var-values var))))
|
||||
|
||||
|
||||
|
||||
(define (instantiate/inner sc recursive-kinds)
|
||||
(define (recur sc)
|
||||
(match sc
|
||||
|
|
|
|||
|
|
@ -72,10 +72,9 @@
|
|||
(t (-poly (a) (-lst a)))
|
||||
(t (-poly (a) (-vec a)))
|
||||
|
||||
#|
|
||||
(t/fail ((-poly (a) (-vec a)) . -> . -Symbol)
|
||||
"some error")
|
||||
|
||||
"cannot generate contract for non-function")
|
||||
#|
|
||||
(t/fail
|
||||
(make-Function
|
||||
(list (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #f)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user