workaround syntax-parse error msg regressions
- just throw explicit type-error exn instead of relying on #:fail-when etc - run-all-tests passing
This commit is contained in:
Stephen Chang
parent
01a0bb28a7
commit
73e59ddec7
|
|
@ -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)])
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user