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

Factor out type alias error helper

Browse Source 
Mainly for single point of control.
This commit is contained in:
Asumu Takikawa 2016-06-22 02:27:58 -04:00
parent c29eb20efc
commit b8225e1100
5 changed files with 31 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
typed-racket-lib/typed-racket/base-env/base-types-extra.rkt
View File

@ -1,20 +1,12 @@
#lang racket/base
(require (for-syntax racket/base syntax/stx))
(require (for-syntax "type-name-error.rkt"
racket/base syntax/stx))
(define-syntax (define-other-types stx)
(syntax-case stx ()
[(_ nm ...)
#'(begin (define-syntax nm
(lambda (stx)
(raise-syntax-error 'type-check
(format "type name used out of context\n type: ~a\n in: ~a"
(syntax->datum (if (stx-pair? stx)
(stx-car stx)
stx))
(syntax->datum stx))
stx
(and (stx-pair? stx) (stx-car stx)))))
#'(begin (define-syntax nm type-name-error)
...
(provide nm) ...)]))

15
typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt
View File

@ -8,7 +8,8 @@
(require "../utils/utils.rkt"
(for-syntax (private parse-type))
(for-syntax racket/base
(for-syntax "type-name-error.rkt"
racket/base
syntax/parse
syntax/stx)
(for-syntax (types abbrev numeric-tower union prop-ops)))
@ -48,17 +49,7 @@
(register-type-name (quote-syntax type)
(make-Opaque #'pred)))
#:with outer-form #'(begin
;; FIXME: same as the one used in prims
;; lift out to utility module maybe
(define-syntax (type stx)
(raise-syntax-error 'type-check
(format "type name used out of context\n type: ~a\n in: ~a"
(syntax->datum (if (stx-pair? stx)
(stx-car stx)
stx))
(syntax->datum stx))
stx
(and (stx-pair? stx) (stx-car stx))))
(define-syntax type type-name-error)
(provide type pred))))
(define-syntax-class struct-clause

15
typed-racket-lib/typed-racket/base-env/prims-contract.rkt
View File

@ -88,7 +88,8 @@
"../typecheck/internal-forms.rkt"
;; struct-extraction is actually used at both of these phases
"../utils/struct-extraction.rkt"
(for-syntax "../utils/struct-extraction.rkt")
(for-syntax "../utils/struct-extraction.rkt"
"type-name-error.rkt")
(only-in "../utils/utils.rkt" syntax-length)
(for-template racket/base "ann-inst.rkt"))
@ -531,17 +532,7 @@
#'(begin))
#,(if (not (free-identifier=? #'nm #'type))
#'(define-syntax type
(lambda (stx)
(raise-syntax-error
'type-check
(format "type name ~a used out of context in ~a"
(syntax->datum (if (stx-pair? stx)
(stx-car stx)
stx))
(syntax->datum stx))
stx
(and (stx-pair? stx) (stx-car stx)))))
#'(define-syntax type type-name-error)
#'(begin))
#,@(if (attribute unsafe.unsafe?)

37
typed-racket-lib/typed-racket/base-env/prims-struct.rkt
View File

@ -21,6 +21,7 @@
racket/struct-info
"../typecheck/internal-forms.rkt"
"annotate-classes.rkt"
"type-name-error.rkt"
"../private/parse-classes.rkt"
"../private/syntax-properties.rkt"
"../typecheck/internal-forms.rkt"))
@ -29,7 +30,8 @@
(lazy-require [syntax/struct (build-struct-names)]))
(provide define-typed-struct -struct define-typed-struct/exec dtsi* dtsi/exec*
define-type-alias define-new-subtype)
define-type-alias define-new-subtype
(for-syntax type-name-error))
(define-for-syntax (with-type* expr ty)
(with-type #`(ann #,expr #,ty)))
@ -118,15 +120,7 @@
#:property prop:procedure proc*)))]
[stx-err-fun (if (not (free-identifier=? #'nm.name #'type))
(syntax/loc stx
(define-syntax type
(lambda (stx)
(raise-syntax-error
'type-check
(format "type name ~a used out of context in ~a"
(syntax->datum (if (stx-pair? stx) (stx-car stx) stx))
(syntax->datum stx))
stx
(and (stx-pair? stx) (stx-car stx))))))
(define-syntax type type-name-error))
#'(begin))]
[dtsi (quasisyntax/loc stx (dtsi/exec* () nm type (fld ...) proc-ty))])
#'(begin d-s stx-err-fun dtsi))]))
@ -187,17 +181,7 @@
. opts.untyped)))]
[stx-err-fun (if (not (free-identifier=? #'nm.name #'type))
(syntax/loc stx
(define-syntax type
(lambda (stx)
(raise-syntax-error
'type-check
(format "type name ~a used out of context in ~a"
(syntax->datum (if (stx-pair? stx)
(stx-car stx)
stx))
(syntax->datum stx))
stx
(and (stx-pair? stx) (stx-car stx))))))
(define-syntax type type-name-error))
#'(begin))]
[dtsi (quasisyntax/loc stx
(dtsi* (vars.vars ...)
@ -231,18 +215,9 @@
(syntax-parse stx
[(_ :type-alias-full)
(define/with-syntax stx-err-fun
#'(lambda (stx)
(raise-syntax-error
'type-check
(format "type name used out of context\n type: ~a\n in: ~a"
(syntax->datum (if (stx-pair? stx) (stx-car stx) stx))
(syntax->datum stx))
stx
(and (stx-pair? stx) (stx-car stx)))))
#`(begin
#,(if (not (attribute omit))
(ignore #'(define-syntax tname stx-err-fun))
(ignore #'(define-syntax tname type-name-error))
#'(begin))
#,(internal (syntax/loc stx
(define-type-alias-internal tname type poly-vars))))]))

16
typed-racket-lib/typed-racket/base-env/type-name-error.rkt Normal file
View File

@ -0,0 +1,16 @@
#lang racket/base
;; Provides an error handling helper for type aliases / type names
(require syntax/stx)
(provide type-name-error)
(define (type-name-error stx)
(raise-syntax-error
'type-check
(format "type name used out of context\n type: ~a\n in: ~a"
(syntax->datum (if (stx-pair? stx) (stx-car stx) stx))
(syntax->datum stx))
stx
(and (stx-pair? stx) (stx-car stx))))