diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-error.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-error.rkt index f37c737dfa..a5707980cd 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-error.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-error.rkt @@ -10,10 +10,13 @@ (provide/cond-contract [tc-error/expr ((string?) (#:return c:any/c #:stx syntax?) #:rest (c:listof c:any/c) . c:->* . c:any/c)] + [tc-error/expr/fields ((string?) (#:more string? #:return c:any/c #:stx syntax?) + #:rest (c:listof c:any/c) . c:->* . c:any/c)] [lookup-fail (identifier? . c:-> . Type/c)] [lookup-type-fail (identifier? . c:-> . Type/c)]) +;; produce a type-checking error, and also return a result (e.g., a type) (define (tc-error/expr msg #:return [return -Bottom] #:stx [stx (current-orig-stx)] @@ -21,6 +24,15 @@ (apply tc-error/delayed #:stx stx msg rest) return) +;; like `tc-error/expr`, but with modern error syntax +(define (tc-error/expr/fields msg + #:more [more #f] + #:stx [stx (current-orig-stx)] + #:return [return -Bottom] + . rst) + (apply tc-error/fields #:more more #:stx stx #:delayed? #t msg rst) + return) + ;; error for unbound variables (define (lookup-fail e) (match (identifier-binding e) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt index a958c37d80..a3169dc2b0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt @@ -5,8 +5,10 @@ This file is for utilities that are only useful for Typed Racket, but don't depend on any other portion of the system |# -(require syntax/source-syntax "disappeared-use.rkt" racket/promise - syntax/parse (for-syntax racket/base syntax/parse) racket/match) +(require syntax/source-syntax "disappeared-use.rkt" + racket/list racket/match racket/promise racket/string + syntax/parse (for-syntax racket/base syntax/parse) + (only-in unstable/sequence in-slice)) (provide ;; parameters current-orig-stx @@ -23,6 +25,7 @@ don't depend on any other portion of the system warn-unreachable report-all-errors + tc-error/fields tc-error/delayed tc-error tc-error/stx @@ -133,6 +136,40 @@ don't depend on any other portion of the system delayed-errors)) (raise-typecheck-error (apply format msg rest) (list stx))))) +;; Produce a type error using modern Racket error syntax. +;; Avoid using format directives in the `msg`, `more`, and `field` +;; strings in the rest argument (may cause unexpected errors) +(define (tc-error/fields msg + #:more [more #f] + #:stx [stx (current-orig-stx)] + #:delayed? [delayed? #f] + . rst) + (unless (even? (length rst)) + (raise-argument-error + 'tc-error/fields + "alternating fields and values" + rst)) + (define-values (field-strs vals) + (for/fold ([field-strs null] [vals null]) + ([field+value (in-slice 2 rst)]) + (match-define (list field value) field+value) + (define field-strs* + (cons (format " ~a: ~~a" field) field-strs)) + (values field-strs* (cons value vals)))) + (define more-msg (if more (string-append ";\n " more "\n") "\n")) + (define all-fields (string-join (reverse field-strs) "\n")) + (define final-msg (chomp (string-append msg more-msg all-fields))) + (if delayed? + (apply tc-error/delayed #:stx stx final-msg (reverse vals)) + (apply tc-error/stx stx final-msg (reverse vals)))) + +;; helper for above, remove \n at end if any +(define (chomp str) + (define len (string-length str)) + (if (eq? #\newline (string-ref str (sub1 len))) + (substring str 0 (sub1 len)) + str)) + ;; produce a type error, using the current syntax (define (tc-error msg . rest) (let* ([ostx (current-orig-stx)]