commit 73e59ddec735a938f48cb77d6c898f3fdf86226b
parent 01a0bb28a78618f979bb464033a989cd9b4aa724
Author: Stephen Chang <stchang@ccs.neu.edu>
Date: Wed, 6 Apr 2016 17:15:20 -0400
workaround syntax-parse error msg regressions
- just throw explicit type-error exn instead of relying on #:fail-when etc
- run-all-tests passing
Diffstat:
4 files changed, 27 insertions(+), 21 deletions(-)
diff --git a/tapl/ext-stlc.rkt b/tapl/ext-stlc.rkt
@@ -23,11 +23,11 @@
(define-base-type Char)
(define-typed-syntax #%datum
- [(_ . b:boolean) (⊢ (#%datum . b) : Bool)]
- [(_ . s:str) (⊢ (#%datum . s) : String)]
- [(_ . f) #:when (flonum? (syntax-e #'f)) (⊢ (#%datum . f) : Float)]
- [(_ . c:char) (⊢ (#%datum . c) : Char)]
- [(_ . x) #'(stlc+lit:#%datum . x)])
+ [(_ . b:boolean) (⊢ #,(syntax/loc stx (#%datum . b)) : Bool)]
+ [(_ . s:str) (⊢ #,(syntax/loc stx (#%datum . s)) : String)]
+ [(_ . f) #:when (flonum? (syntax-e #'f)) (⊢ #,(syntax/loc stx (#%datum . f)) : Float)]
+ [(_ . c:char) (⊢ #,(syntax/loc stx (#%datum . c)) : Char)]
+ [(_ . x) (syntax/loc stx (stlc+lit:#%datum . x))])
(define-primop zero? : (→ Int Bool))
(define-primop = : (→ Int Int Bool))
@@ -114,8 +114,9 @@
#:with ((x- ...) (e- ... e_body-) (τ ... τ_body))
(infers/ctx+erase #'(b ...) #'(e ... e_body))
#:fail-unless (typechecks? #'(b.type ...) #'(τ ...))
- (string-append
- "type check fail, args have wrong type:\n"
+ (type-error #:src stx
+ #:msg (string-append
+ "letrec: type check fail, args have wrong type:\n"
(string-join
(stx-map
(λ (e τ τ-expect)
@@ -123,7 +124,7 @@
"~a has type ~a, expected ~a"
(syntax->datum e) (type->str τ) (type->str τ-expect)))
#'(e ...) #'(τ ...) #'(b.type ...))
- "\n"))
+ "\n")))
(⊢ (letrec ([x- e-] ...) e_body-) : τ_body)])
diff --git a/tapl/infer.rkt b/tapl/infer.rkt
@@ -117,7 +117,8 @@
; #:with [e_fn- (τ_in ... τ_out)] (⇑ e_fn_anno as →)
#:with [e_fn- ((X ...) ((~ext-stlc:→ τ_inX ... τ_outX)))] (⇑ e_fn_anno as ∀)
#:fail-unless (stx-length=? #'(τ_inX ...) #'(e_arg ...)) ; check arity
- (string-append
+ (type-error #:src stx
+ #:msg (string-append
(format "~a (~a:~a) Wrong number of arguments given to function ~a.\n"
(syntax-source stx) (syntax-line stx) (syntax-column stx)
(syntax->datum #'e_fn))
@@ -129,13 +130,14 @@
(map (λ (e t) (format " ~a : ~a" e t)) ; indent each line
(syntax->datum #'(e_arg ...))
(stx-map type->str #'(τ_arg ...)))
- "\n"))
+ "\n")))
#:with cs (compute-constraints #'((τ_inX τ_arg) ...))
#:with (τ_solved ...) (stx-map (λ (y) (lookup y #'cs)) #'(X ...))
#:with (τ_in ... τ_out) (stx-map (λ (t) (substs #'(τ_solved ...) #'(X ...) t)) #'(τ_inX ... τ_outX))
; some code duplication
#:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...))
- (string-append
+ (type-error #:src stx
+ #:msg (string-append
(format "~a (~a:~a) Arguments to function ~a have wrong type(s).\n"
(syntax-source stx) (syntax-line stx) (syntax-column stx)
(syntax->datum #'e_fn))
@@ -147,7 +149,7 @@
"\n" #:after-last "\n")
(format "Expected: ~a arguments with type(s): "
(stx-length #'(τ_in ...)))
- (string-join (stx-map type->str #'(τ_in ...)) ", "))
+ (string-join (stx-map type->str #'(τ_in ...)) ", ")))
; propagate inferred types for variables up
#:with env (stx-flatten (filter (λ (x) x) (stx-map get-env #'(e_arg- ...))))
#:with result-app (add-env #'(#%app e_fn- e_arg- ...) #'env)
@@ -157,7 +159,8 @@
; #:when (printf "fn first ~a\n" (syntax->datum stx))
#:with [e_fn- ((X ...) ((~ext-stlc:→ τ_inX ... τ_outX)))] (⇑ e_fn as ∀)
#:fail-unless (stx-length=? #'(τ_inX ...) #'(e_arg ...)) ; check arity
- (string-append
+ (type-error #:src stx
+ #:msg (string-append
(format "~a (~a:~a) Wrong number of arguments given to function ~a.\n"
(syntax-source stx) (syntax-line stx) (syntax-column stx)
(syntax->datum #'e_fn))
@@ -165,7 +168,7 @@
(stx-length #'(τ_inX ...)))
(string-join (stx-map type->str #'(τ_inX ...)) ", " #:after-last "\n")
"Given args: "
- (string-join (map ~a (syntax->datum #'(e_arg ...))) ", "))
+ (string-join (map ~a (syntax->datum #'(e_arg ...))) ", ")))
; #:with ([e_arg- τ_arg] ...) #'(infers+erase #'(e_arg ...))
#:with (cs ([e_arg- τ_arg] ...))
(let-values ([(cs e+τs)
diff --git a/tapl/stlc+lit.rkt b/tapl/stlc+lit.rkt
@@ -33,7 +33,7 @@
(define-primop + : (→ Int Int Int))
(define-typed-syntax #%datum
- [(_ . n:integer) (⊢ (#%datum . n) : Int)]
+ [(_ . n:integer) (⊢ #,(syntax/loc stx (#%datum . n)) : Int)]
[(_ . x)
#:when (type-error #:src #'x #:msg "Unsupported literal: ~v" #'x)
#'(#%datum . x)])
diff --git a/tapl/stlc.rkt b/tapl/stlc.rkt
@@ -78,7 +78,7 @@
#:note [note ""]
#:name [name #f])
(syntax-parse stx
- [(app . rst)
+ #;[(app . rst)
#:when (not (equal? '#%app (syntax->datum #'app)))
(mk-app-err-msg (syntax/loc stx (#%app app . rst))
#:expected expected-τs
@@ -111,10 +111,12 @@
#:with [e_fn- (τ_in ... τ_out)] (⇑ e_fn as →)
#:with ([e_arg- τ_arg] ...) (infers+erase #'(e_arg ...))
#:fail-unless (stx-length=? #'(τ_arg ...) #'(τ_in ...))
- (mk-app-err-msg stx #:expected #'(τ_in ...)
- #:given #'(τ_arg ...)
- #:note "Wrong number of arguments.")
+ (type-error #:src stx
+ #:msg (mk-app-err-msg stx #:expected #'(τ_in ...)
+ #:given #'(τ_arg ...)
+ #:note "Wrong number of arguments."))
#:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...))
- (mk-app-err-msg stx #:expected #'(τ_in ...)
- #:given #'(τ_arg ...))
+ (type-error #:src stx
+ #:msg (mk-app-err-msg stx #:expected #'(τ_in ...)
+ #:given #'(τ_arg ...)))
(⊢ (#%app e_fn- e_arg- ...) : τ_out)])
