From b8225e11008a2fa910fd3fd34c6af9a8cce0f6f6 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Wed, 22 Jun 2016 02:27:58 -0400 Subject: [PATCH] Factor out type alias error helper Mainly for single point of control. --- .../base-env/base-types-extra.rkt | 14 ++----- .../typed-racket/base-env/extra-env-lang.rkt | 15 ++------ .../typed-racket/base-env/prims-contract.rkt | 15 ++------ .../typed-racket/base-env/prims-struct.rkt | 37 +++---------------- .../typed-racket/base-env/type-name-error.rkt | 16 ++++++++ 5 files changed, 31 insertions(+), 66 deletions(-) create mode 100644 typed-racket-lib/typed-racket/base-env/type-name-error.rkt diff --git a/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt b/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt index e9cef977..31791592 100644 --- a/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt +++ b/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt @@ -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) ...)])) diff --git a/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt b/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt index 8f57525c..b9593b38 100644 --- a/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt +++ b/typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt index 5a03c980..e2b2aebd 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt @@ -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?) diff --git a/typed-racket-lib/typed-racket/base-env/prims-struct.rkt b/typed-racket-lib/typed-racket/base-env/prims-struct.rkt index 22c39366..f25d10ca 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-struct.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-struct.rkt @@ -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))))])) diff --git a/typed-racket-lib/typed-racket/base-env/type-name-error.rkt b/typed-racket-lib/typed-racket/base-env/type-name-error.rkt new file mode 100644 index 00000000..9347a694 --- /dev/null +++ b/typed-racket-lib/typed-racket/base-env/type-name-error.rkt @@ -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))))