suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add TR helpers for new Racket error notation

Browse Source
This commit is contained in:
Asumu Takikawa 2013-12-17 19:37:48 -05:00
parent 54c50dd8d2
commit 0488ce9e0b
2 changed files with 51 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/tc-error.rkt
View File

@ -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)

41
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt
View File

@ -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)]