Make contract generation failure tests pass, and simplify reason logic.
original commit: f17f6655dd2400ffb91e1116513db4ce2056b743
This commit is contained in:
Eric Dobson
parent
6b83691093
commit
b3fc8b5667
|
|
@ -33,11 +33,7 @@
|
|||
[(struct-combinator args _ mut?)
|
||||
(merge-restricts*
|
||||
(if mut? 'chaperone 'flat)
|
||||
(map (lambda (a) (if mut?
|
||||
(add-constraint (f a) 'chaperone
|
||||
(λ (actual-kind) (error "How is this triggered")))
|
||||
(f a)))
|
||||
args))]))])
|
||||
(map (lambda (a) (if (not mut?) (add-constraint (f a) 'chaperone) (f a))) args))]))])
|
||||
|
||||
(define (struct/sc name mut? fields)
|
||||
(struct-combinator fields name mut?))
|
||||
|
|
|
|||
|
|
@ -49,11 +49,7 @@
|
|||
#'(lambda (v recur)
|
||||
(for/list ([arg (in-list (combinator-args v))]
|
||||
[kind (in-list (list 'pos.category-stx ...))])
|
||||
(add-constraint (recur arg) kind
|
||||
(λ (actual-kind)
|
||||
;;TODO add code for a vs an
|
||||
(~a "required a " kind " contract but could only generate a "
|
||||
actual-kind " contract")))))
|
||||
(add-constraint (recur arg) kind)))
|
||||
#:attr combinator2
|
||||
#'(λ (constructor) (λ (pos.name ...) (constructor (list pos.name ...))))
|
||||
#:with matcher
|
||||
|
|
@ -78,11 +74,7 @@
|
|||
#:with ->restricts
|
||||
#'(lambda (v recur)
|
||||
(for/list ([arg (in-list (combinator-args v))])
|
||||
(add-constraint (recur arg) 'rest.category-stx
|
||||
(λ (actual-kind)
|
||||
;;TODO add code for a vs an
|
||||
(~a "required a " 'rest.category-stx " contract but could only generate a "
|
||||
actual-kind " contract")))))
|
||||
(add-constraint (recur arg) 'rest.category-stx)))
|
||||
#: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? string? -> contract-restrict
|
||||
;; add-constraint: contract-restrict? kind? -> 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?
|
||||
|
|
@ -38,6 +38,7 @@
|
|||
(require
|
||||
racket/match
|
||||
racket/list
|
||||
racket/format
|
||||
racket/contract
|
||||
racket/dict
|
||||
racket/set
|
||||
|
|
@ -55,8 +56,7 @@
|
|||
[exn:fail:constraint-failure? predicate/c]
|
||||
[exn:fail:constraint-failure-reason (exn:fail:constraint-failure? . -> . string?)]
|
||||
[validate-constraints (contract-restrict? . -> . void?)]
|
||||
[add-constraint
|
||||
(contract-restrict? contract-kind? (contract-kind? . -> . string?) . -> . contract-restrict?)])
|
||||
[add-constraint (contract-restrict? contract-kind? . -> . contract-restrict?)])
|
||||
contract-restrict-recursive-values
|
||||
|
||||
contract-restrict?
|
||||
|
|
@ -69,15 +69,13 @@
|
|||
"kinds.rkt")
|
||||
(provide
|
||||
(contract-out
|
||||
[struct constraint ([value kind-max?]
|
||||
[max contract-kind?]
|
||||
[reason (contract-kind? . -> . string?)])]
|
||||
[struct constraint ([value kind-max?] [max contract-kind?])]
|
||||
[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 reason) #:transparent)
|
||||
(struct constraint (value max) #:transparent)
|
||||
(struct kind-max (variables max) #:transparent)
|
||||
(struct contract-restrict (value recursive-values constraints) #:transparent))
|
||||
(require 'structs)
|
||||
|
|
@ -107,13 +105,20 @@
|
|||
(define (variable-contract-restrict var)
|
||||
(contract-restrict (kind-max (free-id-set var) 'flat) (make-immutable-free-id-table) (set)))
|
||||
|
||||
(define (reason-string actual bound)
|
||||
(define (name k)
|
||||
(case k
|
||||
[(flat chaperone) (~a "a " k " contract")]
|
||||
[(impersonator) "an impersonator contract"]))
|
||||
(~a "required " (name bound) " but generated " (name actual)))
|
||||
|
||||
(define (add-constraint cr max reason)
|
||||
|
||||
(define (add-constraint cr max)
|
||||
(if (equal? 'impersonator max)
|
||||
cr
|
||||
(match cr
|
||||
[(contract-restrict v rec constraints)
|
||||
(contract-restrict v rec (set-add constraints (constraint v max reason)))])))
|
||||
(contract-restrict v rec (set-add constraints (constraint v max)))])))
|
||||
|
||||
(define (add-recursive-values cr dict)
|
||||
(match cr
|
||||
|
|
@ -184,10 +189,11 @@
|
|||
[(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 reason)
|
||||
[(constraint (kind-max (app dict-count 0) kind) bound)
|
||||
(unless (contract-kind<= kind bound)
|
||||
(define reason (reason-string kind bound))
|
||||
(raise (exn:fail:constraint-failure
|
||||
(format "Violated constraint: ~a" reason)
|
||||
(current-continuation-marks)
|
||||
(reason kind))))]))]))
|
||||
reason)))]))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -43,13 +43,7 @@
|
|||
[(? sc?)
|
||||
(sc->constraints sc recur)]))
|
||||
(define constraints (recur sc))
|
||||
(validate-constraints
|
||||
(add-constraint
|
||||
constraints
|
||||
max-kind
|
||||
(λ (actual-kind)
|
||||
;;TODO add code for a vs an
|
||||
(format "required a ~a contract but could only generate a ~a contract" max-kind actual-kind))))
|
||||
(validate-constraints (add-constraint constraints max-kind))
|
||||
constraints)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -36,7 +36,6 @@
|
|||
(fail-check "Reason didn't match expected.")))))))
|
||||
|
||||
|
||||
;; These will fail when the bug is fixed.
|
||||
(define known-bugs
|
||||
(test-suite "Known Bugs"
|
||||
|
||||
|
|
@ -73,7 +72,7 @@
|
|||
(t (-poly (a) (-vec a)))
|
||||
|
||||
(t/fail ((-poly (a) (-vec a)) . -> . -Symbol)
|
||||
"cannot generate contract for non-function")
|
||||
"cannot generate contract for non-function polymorphic type")
|
||||
(t/fail
|
||||
(make-Function
|
||||
(list (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #f)))
|
||||
|
|
@ -88,11 +87,11 @@
|
|||
(t/fail (-struct #'struct-name #f (list (make-fld -Symbol #'acc #f)) (-> -Symbol))
|
||||
"procedural structs are not supported")
|
||||
(t/fail (-Syntax (-> -Boolean -Boolean))
|
||||
#rx"required a flat contract but could only generate a chaperone contract")
|
||||
"required a flat contract but generated a chaperone contract")
|
||||
(t/fail (-Syntax (-seq -Boolean))
|
||||
#rx"required a flat contract but could only generate a impersonator contract")
|
||||
"required a flat contract but generated an impersonator contract")
|
||||
(t/fail (-set (-seq -Boolean))
|
||||
#rx"required a chaperone contract but could only generate a impersonator contract")
|
||||
"required a chaperone contract but generated an impersonator contract")
|
||||
|
||||
(t/fail
|
||||
(make-Function
|
||||
|
|
@ -100,5 +99,7 @@
|
|||
(make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #t)))
|
||||
(make-arr* (list Univ Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #t)))))
|
||||
"case function type with optional keyword arguments")
|
||||
(t/fail (-vec (-struct #'struct-name #f (list (make-fld (-seq -Symbol) #'acc #f)) #f #t))
|
||||
"required a chaperone contract but generated an impersonator contract")
|
||||
|
||||
))
|
||||
|
|
|
|||
|
|
@ -24,12 +24,12 @@
|
|||
['location (build-source-location-list (quote-srcloc e))])
|
||||
(phase1-phase0-eval
|
||||
(define sc
|
||||
(type->static-contract e (lambda _ #f)))
|
||||
(type->static-contract e (lambda (#:reason _) #f)))
|
||||
(if sc
|
||||
#`(with-check-info (['static '#,sc])
|
||||
(phase1-phase0-eval
|
||||
(define ctc (instantiate '#,sc
|
||||
(lambda _ (error "static-contract could not be converted to a contract"))))
|
||||
(lambda (#:reason _) (error "static-contract could not be converted to a contract"))))
|
||||
#,#'#`(with-check-info (['contract '#,ctc])
|
||||
(define runtime-contract #,ctc)
|
||||
(check-pred contract? runtime-contract))))
|
||||
|
|
@ -42,7 +42,7 @@
|
|||
(define sc
|
||||
(phase1-phase0-eval
|
||||
(let/ec exit
|
||||
#`'#,(type->static-contract e (lambda _ (exit #'#f)) #:typed-side typed-side))))
|
||||
#`'#,(type->static-contract e (lambda (#:reason _) (exit #'#f)) #:typed-side typed-side))))
|
||||
(when sc
|
||||
(with-check-info (['static sc])
|
||||
(fail-check "Type was incorrectly converted to contract"))))]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user