diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt index 69e70f6fa4..122db8cb9b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt @@ -1,8 +1,27 @@ #lang racket/base -(require (for-syntax racket/base) - syntax/parse) +(require + syntax/parse + (for-syntax racket/base racket/syntax + syntax/parse syntax/parse/experimental/template) + (for-template racket/base)) +(provide + type-alias + type-refinement + typed-struct + typed-struct/exec + typed-require + typed-require/struct + predicate-assertion + type-declaration + failed-typecheck + + type-alias? + typed-struct? + typed-struct/exec?) + +;; Forms (define-syntax-rule (internal-forms set-name nms ...) (begin (provide nms ... set-name) @@ -20,3 +39,78 @@ :-internal typecheck-fail-internal) + + +;;; Helpers + +(define-splicing-syntax-class dtsi-fields + #:attributes (mutable type-only maker) + (pattern + (~seq + (~or (~optional (~and #:mutable (~bind (mutable #t)))) + (~optional (~and #:type-only (~bind (type-only #t)))) + (~optional (~seq #:maker maker))) ...))) + +(define-syntax-class struct-name + (pattern nm:id) + (pattern (nm:id parent:id))) + + +(define-syntax-class define-typed-struct-body + #:attributes (name mutable type-only maker nm (tvars 1) (fields 1) (types 1)) + (pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null))) + nm:struct-name ([fields:id : types:expr] ...) options:dtsi-fields) + #:attr name #'nm.nm + #:attr mutable (attribute options.mutable) + #:attr type-only (attribute options.type-only) + #:attr maker (or (attribute options.maker) #'nm.nm))) + +;;; Internal form syntax matching + + +(define-syntax-class internal + #:attributes (value) + #:literals (values) + #:literal-sets (kernel-literals) + (pattern (define-values () (begin (quote-syntax value:expr) (#%plain-app values))))) + +(define-syntax (define-internal-classes stx) + (define-syntax-class clause + (pattern [name:id (lit:id . body:expr)] + #:with pred (format-id #'name "~a?" #'name))) + + (syntax-parse stx + [(_ :clause ...) + (template + (begin + (begin + (define-syntax-class name + #:auto-nested-attributes + #:literal-sets ((internal-literals #:at name)) + (pattern i:internal #:with (lit . body) #'i.value)) + (define pred + (syntax-parser + [(~var _ name) #t] + [_ #f]))) ...))])) + + +(define-internal-classes + [type-alias + (define-type-alias-internal name type)] + [type-refinement + (declare-refinement-internal predicate)] + [typed-struct + (define-typed-struct-internal . :define-typed-struct-body)] + [typed-struct/exec + (define-typed-struct/exec-internal nm ([fields:id : types] ...) proc-type)] + [typed-require + (require/typed-internal name type)] + [typed-require/struct + (require/typed-internal name type #:struct-maker parent)] + [predicate-assertion + (assert-predicate-internal type predicate)] + [type-declaration + (:-internal id:identifier type)] + [failed-typecheck + (typecheck-fail-internal stx message:str var:id)]) + diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index 71e7533949..f82b02c4df 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -8,12 +8,13 @@ (types utils abbrev union subtype type-table) (private-in parse-type type-annotation syntax-properties) (rep type-rep filter-rep object-rep) - (utils tc-utils syntax-classes) + (utils tc-utils) (env lexical-env tvar-env index-env) racket/private/class-internal syntax/parse syntax/stx unstable/syntax (only-in srfi/1 split-at) + (typecheck internal-forms) (for-template (only-in '#%paramz [parameterization-key pz:pk]))) (require (for-template racket/base racket/private/class-internal)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt index 1d1f97f709..f5ce82adad 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt @@ -7,9 +7,8 @@ (private type-annotation parse-type syntax-properties) (env lexical-env type-alias-env global-env type-env-structs scoped-tvar-env) (rep type-rep filter-rep) - (utils syntax-classes) syntax/free-vars - (typecheck signatures tc-metafunctions tc-subst) + (typecheck signatures tc-metafunctions tc-subst internal-forms) racket/match (contract-req) syntax/parse syntax/stx (for-template racket/base)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt index 11dcce4972..007284d284 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt @@ -9,8 +9,8 @@ (private parse-type syntax-properties) (types abbrev utils resolve substitute type-table struct-table) (env global-env type-name-env tvar-env) - (utils tc-utils syntax-classes) - (typecheck def-binding) + (utils tc-utils) + (typecheck def-binding internal-forms) (for-syntax syntax/parse racket/base) (for-template racket/base)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index 66c2e2d4ab..d8e4637a1c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -9,8 +9,9 @@ (private parse-type type-annotation type-contract syntax-properties) (env global-env init-envs type-name-env type-alias-env lexical-env env-req mvar-env scoped-tvar-env) - (utils tc-utils syntax-classes) - (typecheck provide-handling def-binding tc-structs typechecker) + (utils tc-utils) + (typecheck provide-handling def-binding tc-structs + typechecker internal-forms) syntax/location diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-classes.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-classes.rkt deleted file mode 100644 index 1a50aa8bb4..0000000000 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-classes.rkt +++ /dev/null @@ -1,97 +0,0 @@ -#lang racket/base - -(require - (only-in "utils.rkt" typecheck) - syntax/parse - (for-syntax racket/base racket/syntax - syntax/parse syntax/parse/experimental/template) - (only-in (typecheck internal-forms) internal-literals) - (for-template racket/base)) -(provide - type-alias - type-refinement - typed-struct - typed-struct/exec - typed-require - typed-require/struct - predicate-assertion - type-declaration - failed-typecheck - - type-alias? - typed-struct? - typed-struct/exec? - ) - -;;; Helpers - -(define-splicing-syntax-class dtsi-fields - #:attributes (mutable type-only maker) - (pattern - (~seq - (~or (~optional (~and #:mutable (~bind (mutable #t)))) - (~optional (~and #:type-only (~bind (type-only #t)))) - (~optional (~seq #:maker maker))) ...))) - -(define-syntax-class struct-name - (pattern nm:id) - (pattern (nm:id parent:id))) - - -(define-syntax-class define-typed-struct-body - #:attributes (name mutable type-only maker nm (tvars 1) (fields 1) (types 1)) - (pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null))) - nm:struct-name ([fields:id : types:expr] ...) options:dtsi-fields) - #:attr name #'nm.nm - #:attr mutable (attribute options.mutable) - #:attr type-only (attribute options.type-only) - #:attr maker (or (attribute options.maker) #'nm.nm))) - -;;; Internal form syntax matching - - -(define-syntax-class internal - #:attributes (value) - #:literals (values) - #:literal-sets (kernel-literals) - (pattern (define-values () (begin (quote-syntax value:expr) (#%plain-app values))))) - -(define-syntax (define-internal-classes stx) - (define-syntax-class clause - (pattern [name:id (lit:id . body:expr)] - #:with pred (format-id #'name "~a?" #'name))) - - (syntax-parse stx - [(_ :clause ...) - (template - (begin - (begin - (define-syntax-class name - #:auto-nested-attributes - #:literal-sets ((internal-literals #:at name)) - (pattern i:internal #:with (lit . body) #'i.value)) - (define pred - (syntax-parser - [(~var _ name) #t] - [_ #f]))) ...))])) - - -(define-internal-classes - [type-alias - (define-type-alias-internal name type)] - [type-refinement - (declare-refinement-internal predicate)] - [typed-struct - (define-typed-struct-internal . :define-typed-struct-body)] - [typed-struct/exec - (define-typed-struct/exec-internal nm ([fields:id : types] ...) proc-type)] - [typed-require - (require/typed-internal name type)] - [typed-require/struct - (require/typed-internal name type #:struct-maker parent)] - [predicate-assertion - (assert-predicate-internal type predicate)] - [type-declaration - (:-internal id:identifier type)] - [failed-typecheck - (typecheck-fail-internal stx message:str var:id)])