Improve type->contract error messages
original commit: 0b78356be72274c07553047f5f95614e329617c3
This commit is contained in:
Asumu Takikawa
parent
3c39fd0c95
commit
deaf4861c2
|
|
@ -85,7 +85,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
(lazy-require ["../rep/type-rep.rkt" (make-Opaque Error?)]
|
||||
[syntax/define (normalize-definition)]
|
||||
[typed-racket/private/parse-type (parse-type)]
|
||||
[typed-racket/private/type-contract (type->contract)]
|
||||
[typed-racket/private/type-contract (type->contract type->contract-fail)]
|
||||
[typed-racket/env/type-name-env (register-type-name)]))
|
||||
|
||||
(define-for-syntax (ignore stx) (ignore-property stx #t))
|
||||
|
|
@ -161,8 +161,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
;; this is for a `require/typed', so the value is not
|
||||
;; from the typed side
|
||||
#:typed-side #f
|
||||
(lambda ()
|
||||
(tc-error/stx #'ty "Type ~a could not be converted to a contract." typ)))))
|
||||
(type->contract-fail typ #'ty))))
|
||||
;; in the fix-up case, the contract is just an identifier
|
||||
;; that is defined below
|
||||
(generate-temporary #'nm.nm)))
|
||||
|
|
@ -270,7 +269,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
#:kind 'flat
|
||||
;; the value is not from the typed side
|
||||
#:typed-side #f
|
||||
(lambda () (tc-error/stx #'ty "Type ~a could not be converted to a predicate." typ)))
|
||||
(type->contract-fail typ #'ty #:ctc-str "predicate"))
|
||||
#t)
|
||||
(Any -> Boolean : ty)))))]))
|
||||
|
||||
|
|
@ -316,8 +315,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
typ
|
||||
;; the value is not from the typed side
|
||||
#:typed-side #f
|
||||
(lambda ()
|
||||
(tc-error/stx #'ty "Type ~a could not be converted to a contract" typ))))))])]))
|
||||
(type->contract-fail typ #'ty)))))])]))
|
||||
|
||||
(define-for-syntax (fail stx)
|
||||
(syntax-parse stx
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
|
||||
;; Contract generation for Typed Racket
|
||||
|
||||
(provide type->contract define/fixup-contract? change-contract-fixups)
|
||||
(provide type->contract define/fixup-contract? change-contract-fixups
|
||||
type->contract-fail)
|
||||
|
||||
(require
|
||||
"../utils/utils.rkt"
|
||||
|
|
@ -14,6 +15,8 @@
|
|||
(prefix-in t: (types abbrev numeric-tower))
|
||||
(private parse-type syntax-properties)
|
||||
racket/match syntax/stx racket/syntax racket/list
|
||||
racket/format
|
||||
unstable/list
|
||||
unstable/sequence
|
||||
(contract-req)
|
||||
(for-template racket/base racket/contract racket/set (utils any-wrap)
|
||||
|
|
@ -44,6 +47,19 @@
|
|||
(typechecker:flat-contract-def stx)
|
||||
(typechecker:contract-def/maker stx)))
|
||||
|
||||
;; type->contract-fail : Syntax Type #:ctc-str String
|
||||
;; -> #:reason (Option String) -> Void
|
||||
;; Curried function that produces a function to report
|
||||
;; type->contract failures
|
||||
(define ((type->contract-fail to-check to-report
|
||||
#:ctc-str [ctc-str "contract"])
|
||||
#:reason [reason #f])
|
||||
(tc-error/stx
|
||||
to-report
|
||||
(~a "Type ~a could not be converted to a "
|
||||
ctc-str
|
||||
(if reason (~a ": " reason) "."))
|
||||
to-check))
|
||||
|
||||
(define (generate-contract-def stx)
|
||||
(define prop (define/fixup-contract? stx))
|
||||
|
|
@ -61,11 +77,7 @@
|
|||
;; this is for a `require/typed', so the value is not from the typed side
|
||||
#:typed-side #f
|
||||
#:kind kind
|
||||
(λ ()
|
||||
(tc-error/stx
|
||||
prop
|
||||
"Type ~a could not be converted to a contract."
|
||||
typ)))])
|
||||
(type->contract-fail typ prop))])
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(define-values (n)
|
||||
|
|
@ -81,9 +93,6 @@
|
|||
e
|
||||
(generate-contract-def e))))
|
||||
|
||||
(define (no-duplicates l)
|
||||
(= (length l) (length (remove-duplicates l))))
|
||||
|
||||
;; To avoid misspellings
|
||||
(define impersonator-sym 'impersonator)
|
||||
(define chaperone-sym 'chaperone)
|
||||
|
|
@ -230,7 +239,9 @@
|
|||
null
|
||||
(map t->c rngs)
|
||||
(and rst (t->c/neg rst)))
|
||||
(exit (fail)))]
|
||||
(exit (fail #:reason
|
||||
(~a "cannot generate contract for function type"
|
||||
" with filters or objects."))))]
|
||||
[_ (exit (fail))]))
|
||||
(with-syntax*
|
||||
([(dom* ...) (process-dom dom*)]
|
||||
|
|
@ -246,12 +257,16 @@
|
|||
#'(dom* ... rst-spec ... . -> . rng*)
|
||||
#'((dom* ...) (opt-dom* ...) rst-spec ... . ->* . rng*))
|
||||
#'(dom* ... . -> . rng*)))))
|
||||
(unless (no-duplicates (for/list ([t (in-list arrs)])
|
||||
(match t
|
||||
[(arr: dom _ _ _ _) (length dom)]
|
||||
;; is there something more sensible here?
|
||||
[(top-arr:) (int-err "got top-arr")])))
|
||||
(exit (fail)))
|
||||
(define arities (for/list ([t (in-list 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 #:same? =))
|
||||
(when maybe-dup
|
||||
(define reason
|
||||
(~a "function type has two cases of arity " maybe-dup))
|
||||
(exit (fail #:reason reason)))
|
||||
(match (map (f (not (= 1 (length arrs)))) arrs)
|
||||
[(list e) e]
|
||||
[l #`(case-> #,@l)])])]
|
||||
|
|
@ -259,10 +274,16 @@
|
|||
|
||||
;; Helpers for contract requirements
|
||||
(define (set-impersonator!)
|
||||
(when (not (equal? kind impersonator-sym)) (exit (fail)))
|
||||
(when (not (equal? kind impersonator-sym))
|
||||
(exit (fail #:reason
|
||||
(~a "required a chaperone or flat contract but could"
|
||||
" only generate an impersonator contract."))))
|
||||
(increase-current-contract-kind! impersonator-sym))
|
||||
(define (set-chaperone!)
|
||||
(when (equal? kind flat-sym) (exit (fail)))
|
||||
(when (equal? kind flat-sym)
|
||||
(exit (fail #:reason
|
||||
(~a "required a first-order contract but could"
|
||||
" only generate a higher-order contract."))))
|
||||
(increase-current-contract-kind! chaperone-sym))
|
||||
|
||||
|
||||
|
|
@ -341,7 +362,8 @@
|
|||
#`(and/c #,(t->c par) (flat-contract #,p?))]
|
||||
[(Union: elems)
|
||||
(let-values ([(vars notvars) (partition F? elems)])
|
||||
(unless (>= 1 (length vars)) (exit (fail)))
|
||||
(unless (>= 1 (length vars))
|
||||
(exit (fail #:reason "union type includes multiple distinct type variables")))
|
||||
(with-syntax
|
||||
([cnts (append (map t->c vars) (map t->c notvars))])
|
||||
#'(or/c . cnts)))]
|
||||
|
|
@ -386,7 +408,7 @@
|
|||
[(PolyDots: _ body) (loop body)]
|
||||
[_ #f])))
|
||||
(unless function-type?
|
||||
(exit (fail)))
|
||||
(exit (fail #:reason "cannot generate contract for non-function polymorphic type")))
|
||||
(if (not (from-untyped? typed-side))
|
||||
;; in typed positions, no checking needed for the variables
|
||||
(parameterize ([vars (append (for/list ([v (in-list vs)]) (list v #'any/c)) (vars))])
|
||||
|
|
@ -431,9 +453,11 @@
|
|||
[(assf (λ (t) (type-equal? t ty)) structs-seen)
|
||||
=>
|
||||
cdr]
|
||||
[proc (exit (fail))]
|
||||
[proc (exit (fail #:reason "procedural structs are not supported"))]
|
||||
[(and (equal? kind flat-sym) (ormap values mut?))
|
||||
(exit (fail))]
|
||||
(exit (fail #:reason
|
||||
(~a "expected a first-order contract, but got"
|
||||
" a struct with at least one mutable field")))]
|
||||
[poly?
|
||||
(with-syntax* ([struct-ctc (generate-temporary 'struct-ctc)])
|
||||
(define field-contracts
|
||||
|
|
@ -462,6 +486,6 @@
|
|||
(when (equal? kind flat-sym) (exit (fail)))
|
||||
#`(hash/c #,(t->c k #:kind chaperone-sym) #,(t->c v) #:immutable 'dont-care)]
|
||||
[else
|
||||
(exit (fail))]))))
|
||||
(exit (fail #:reason "contract generation not supported for this type"))]))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -27,8 +27,8 @@
|
|||
(define old-context (unbox typed-context?))
|
||||
(unless (not old-context)
|
||||
(tc-error/stx stx "with-type cannot be used in a typed module."))
|
||||
(define ((no-contract t [stx stx]))
|
||||
(tc-error/stx stx "Type ~a could not be converted to a contract." t))
|
||||
(define (no-contract t [stx stx])
|
||||
(type->contract-fail t stx))
|
||||
(set-box! typed-context? #t)
|
||||
(init)
|
||||
(define fv-types (for/list ([t (in-syntax fvtys)])
|
||||
|
|
|
|||
|
|
@ -132,7 +132,7 @@
|
|||
|
||||
;; mk-value-triple : identifier? identifier? (or/c syntax? #f) -> triple/c
|
||||
(define (mk-value-triple internal-id new-id ty)
|
||||
(define contract (type->contract ty (λ () #f)))
|
||||
(define contract (type->contract ty (λ (#:reason [reason #f]) #f)))
|
||||
|
||||
(with-syntax* ([id internal-id]
|
||||
[untyped-id (freshen-id #'id)]
|
||||
|
|
|
|||
|
|
@ -8,13 +8,21 @@
|
|||
rackunit)
|
||||
|
||||
(define-syntax-rule (t e)
|
||||
(test-not-exn (format "~a" e) (lambda () (type->contract e (lambda _ (error "type could not be converted to contract"))))))
|
||||
(test-not-exn
|
||||
(format "~a" e)
|
||||
(λ ()
|
||||
(type->contract
|
||||
e
|
||||
(λ (#:reason [reason #f])
|
||||
(error "type could not be converted to contract"))))))
|
||||
|
||||
(define-syntax-rule (t/fail e)
|
||||
(test-not-exn (format "~a" e) (lambda ()
|
||||
(let/ec exit
|
||||
(type->contract e (lambda _ (exit #t)))
|
||||
(error "type could be converted to contract")))))
|
||||
(test-not-exn
|
||||
(format "~a" e)
|
||||
(λ ()
|
||||
(let/ec exit
|
||||
(type->contract e (λ (#:reason [reason #f]) (exit #t)))
|
||||
(error "type could be converted to contract")))))
|
||||
|
||||
(define (contract-tests)
|
||||
(test-suite "Contract Tests"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user