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

Improve error messages from require/contract

Browse Source 
svn: r15716

original commit: 35336e77b86d137b21f36f1f216bd50ae98d0050
This commit is contained in:
Sam Tobin-Hochstadt 2009-08-12 20:28:08 +00:00
parent 3df1a5b1a8
commit c555ae3a9b
1 changed files with 21 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/typed-scheme/utils/require-contract.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/contract (for-syntax scheme/base syntax/kerncase
syntax/parse
"../utils/tc-utils.ss"
(prefix-in tr: "../private/typed-renaming.ss")))
@ -30,23 +31,23 @@
(tr:get-alternate #'id)]))
(define-syntax (require/contract stx)
(syntax-case stx ()
[(require/contract nm cnt lib)
(identifier? #'nm)
(begin
#`(begin (require (only-in lib [nm tmp]))
(define-ignored nm
(contract cnt
(get-alternate tmp)
'(interface for #,(syntax->datum #'nm))
'never-happen
(quote-syntax nm)))))]
[(require/contract (orig-nm nm) cnt lib)
(begin
#`(begin (require (only-in lib [orig-nm tmp]))
(define-ignored nm
(contract cnt
(get-alternate tmp)
'#,(syntax->datum #'nm)
'never-happen
(quote-syntax nm)))))]))
(define-syntax-class renameable
(pattern nm:id
#:with r ((make-syntax-introducer) #'nm)))
(syntax-parse stx
[(require/contract nm:renameable cnt lib)
#`(begin (require (only-in lib [nm nm.r]))
(define-ignored nm
(contract cnt
(get-alternate nm.r)
'(interface for #,(syntax->datum #'nm))
'never-happen
(quote-syntax nm))))]
[(require/contract (orig-nm:renameable nm:id) cnt lib)
#`(begin (require (only-in lib [orig-nm orig-nm.r]))
(define-ignored nm
(contract cnt
(get-alternate orig-nm.r)
'#,(syntax->datum #'nm)
'never-happen
(quote-syntax nm))))]))