Made error messages better for contract generation failures.
original commit: 1acd1537e8e439376da4c925dd4cc96334467f16
This commit is contained in:
Eric Dobson
parent
9525b658d1
commit
6b83691093
|
|
@ -14,6 +14,7 @@
|
|||
racket/match racket/syntax racket/list
|
||||
racket/format
|
||||
racket/dict
|
||||
unstable/list
|
||||
unstable/sequence
|
||||
(static-contracts instantiate optimize structures combinators)
|
||||
;; TODO make this from contract-req
|
||||
|
|
@ -288,7 +289,7 @@
|
|||
[(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred?)
|
||||
(cond
|
||||
[(dict-ref recursive-values nm #f)]
|
||||
[proc (fail #:reason "t->sc2")]
|
||||
[proc (fail #:reason "procedural structs are not supported")]
|
||||
[poly?
|
||||
(define nm* (generate-temporary #'n*))
|
||||
(define fields
|
||||
|
|
@ -311,7 +312,7 @@
|
|||
[(Channel: t)
|
||||
(channel/sc (t->sc t))]
|
||||
[else
|
||||
(fail #:reason "t->sc3")]))))
|
||||
(fail #:reason "contract generation not supported for this type")]))))
|
||||
|
||||
(define (t->sc/function f fail typed-side recursive-values loop method?)
|
||||
(define (t->sc t #:recursive-values (recursive-values recursive-values))
|
||||
|
|
@ -372,14 +373,15 @@
|
|||
(define rest (and rst (listof/sc (t->sc/neg rst))))
|
||||
(function/sc (process-dom mand-args) opt-args mand-kws opt-kws rest range)])]
|
||||
[else
|
||||
(define ((f [case-> #f]) a)
|
||||
(define ((f case->) a)
|
||||
(define (convert-arr arr)
|
||||
(match arr
|
||||
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f kws)
|
||||
(let-values ([(mand-kws opt-kws) (partition-kws kws)])
|
||||
;; Garr, I hate case->!
|
||||
(when (and (not (empty? kws)) case->)
|
||||
(fail #:reason "t->sc4"))
|
||||
(fail #:reason (~a "cannot generate contract for case function type"
|
||||
" with optional keyword arguments")))
|
||||
(if case->
|
||||
(arr/sc (map t->sc/neg dom) (and rst (t->sc/neg rst)) (map t->sc rngs))
|
||||
(function/sc
|
||||
|
|
@ -396,15 +398,18 @@
|
|||
;; functions with filters or objects
|
||||
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f kws)
|
||||
(if (from-untyped? typed-side)
|
||||
(fail #:reason "t->sc5")
|
||||
(convert-arr a))]
|
||||
[_ (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 #:reason "t->sc7"))
|
||||
(fail #:reason (~a "cannot generate contract for function type"
|
||||
" with filters or objects."))
|
||||
(convert-arr a))]))
|
||||
(define arities
|
||||
(for/list ([t arrs])
|
||||
(match t
|
||||
[(arr: dom _ _ _ _) (length dom)]
|
||||
;; is there something more sensible here?
|
||||
[(top-arr:) (int-err "got top-arr")])))
|
||||
(define maybe-dup (check-duplicate arities))
|
||||
(when maybe-dup
|
||||
(fail #:reason (~a "function type has two cases of arity " maybe-dup)))
|
||||
(if (= (length arrs) 1)
|
||||
((f #f) (first arrs))
|
||||
(case->/sc (map (f #t) arrs)))])]
|
||||
|
|
|
|||
|
|
@ -34,7 +34,8 @@
|
|||
(merge-restricts*
|
||||
(if mut? 'chaperone 'flat)
|
||||
(map (lambda (a) (if mut?
|
||||
(add-constraint (f a) 'chaperone "reason3")
|
||||
(add-constraint (f a) 'chaperone
|
||||
(λ (actual-kind) (error "How is this triggered")))
|
||||
(f a)))
|
||||
args))]))])
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
racket/list racket/match
|
||||
(for-syntax racket/base racket/syntax syntax/stx syntax/parse)
|
||||
racket/set
|
||||
racket/format
|
||||
unstable/contract
|
||||
(for-template racket/base
|
||||
racket/contract/base
|
||||
|
|
@ -48,7 +49,11 @@
|
|||
#'(lambda (v recur)
|
||||
(for/list ([arg (in-list (combinator-args v))]
|
||||
[kind (in-list (list 'pos.category-stx ...))])
|
||||
(add-constraint (recur arg) kind "reason1")))
|
||||
(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")))))
|
||||
#:attr combinator2
|
||||
#'(λ (constructor) (λ (pos.name ...) (constructor (list pos.name ...))))
|
||||
#:with matcher
|
||||
|
|
@ -73,7 +78,11 @@
|
|||
#:with ->restricts
|
||||
#'(lambda (v recur)
|
||||
(for/list ([arg (in-list (combinator-args v))])
|
||||
(add-constraint (recur arg) 'rest.category-stx "reason2")))
|
||||
(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")))))
|
||||
#:with matcher
|
||||
#'(define-match-expander matcher-name
|
||||
(syntax-parser
|
||||
|
|
|
|||
|
|
@ -55,7 +55,8 @@
|
|||
[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? string? . -> . contract-restrict?)])
|
||||
[add-constraint
|
||||
(contract-restrict? contract-kind? (contract-kind? . -> . string?) . -> . contract-restrict?)])
|
||||
contract-restrict-recursive-values
|
||||
|
||||
contract-restrict?
|
||||
|
|
@ -68,7 +69,9 @@
|
|||
"kinds.rkt")
|
||||
(provide
|
||||
(contract-out
|
||||
[struct constraint ([value kind-max?] [max contract-kind?] [reason string?])]
|
||||
[struct constraint ([value kind-max?]
|
||||
[max contract-kind?]
|
||||
[reason (contract-kind? . -> . string?)])]
|
||||
[struct kind-max ([variables free-id-table?] [max contract-kind?])]
|
||||
[struct contract-restrict ([value kind-max?]
|
||||
[recursive-values free-id-table?]
|
||||
|
|
@ -186,5 +189,5 @@
|
|||
(raise (exn:fail:constraint-failure
|
||||
(format "Violated constraint: ~a" reason)
|
||||
(current-continuation-marks)
|
||||
reason)))]))]))
|
||||
(reason kind))))]))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -43,7 +43,13 @@
|
|||
[(? sc?)
|
||||
(sc->constraints sc recur)]))
|
||||
(define constraints (recur sc))
|
||||
(validate-constraints (add-constraint constraints max-kind "reason4"))
|
||||
(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))))
|
||||
constraints)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -36,11 +36,11 @@
|
|||
(fail-check "Reason didn't match expected.")))))))
|
||||
|
||||
|
||||
;; These will fail when the bug is fixed.
|
||||
(define known-bugs
|
||||
(test-suite "Known Bugs"
|
||||
|
||||
;; Polydotted functions should work
|
||||
#;
|
||||
(t/fail (-polydots (a) (->... (list) (a a) -Symbol))
|
||||
"not supported for this type")
|
||||
|
||||
|
|
@ -74,7 +74,6 @@
|
|||
|
||||
(t/fail ((-poly (a) (-vec a)) . -> . -Symbol)
|
||||
"cannot generate contract for non-function")
|
||||
#|
|
||||
(t/fail
|
||||
(make-Function
|
||||
(list (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #f)))
|
||||
|
|
@ -86,23 +85,20 @@
|
|||
(-> -Boolean -Boolean)
|
||||
(-> -Symbol -Symbol))
|
||||
"two cases of arity 1")
|
||||
(t/fail (-Syntax (-HT -Symbol -Symbol))
|
||||
"first-order contract, but got a hashtable.")
|
||||
(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 first-order .* generate a higher-order")
|
||||
#rx"required a flat contract but could only generate a chaperone contract")
|
||||
(t/fail (-Syntax (-seq -Boolean))
|
||||
#rx"required a flat contract but could only generate a impersonator contract")
|
||||
(t/fail (-set (-seq -Boolean))
|
||||
#rx"required a chaperone or flat contract .* generate an impersonator")
|
||||
#rx"required a chaperone contract but could only generate a impersonator contract")
|
||||
|
||||
(t/fail
|
||||
(make-Function
|
||||
(list
|
||||
(make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #t)))
|
||||
(make-arr* (list Univ Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #t)))))
|
||||
"some error")
|
||||
"case function type with optional keyword arguments")
|
||||
|
||||
(t/fail (-Syntax (-struct #'struct-name #f (list (make-fld -Symbol #'acc #t)) #f #t))
|
||||
"some error")
|
||||
|#
|
||||
))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user