From 47095366532ade9888c37f909ef45d3360b300cc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 18 Mar 2015 11:31:11 -0400 Subject: [PATCH] Split `prims.rkt` to reduce dependencies. There are several new files: one for structure prims, one for annotation-related prims, one for contract related ones. The prims-contract file uses trickery with submodules to avoid a direct dependency on `racket/contract`. Additionally, the rewritten versions of `for/set` et al now use a submodule to avoid a direct dependency on `racket/set`. --- .../typed-racket/base-env/ann-inst.rkt | 39 ++ .../typed-racket/base-env/base-types.rkt | 3 +- .../typed-racket/base-env/class-prims.rkt | 2 +- .../typed-racket/base-env/colon.rkt | 2 +- .../typed-racket/base-env/prims-contract.rkt | 438 ++++++++++++ .../typed-racket/base-env/prims-struct.rkt | 211 ++++++ .../typed-racket/base-env/prims.rkt | 628 ++---------------- .../typecheck/check-class-unit.rkt | 2 +- .../typed-racket/typecheck/internal-forms.rkt | 69 +- .../typed-racket/typed-racket.rkt | 8 +- .../typed-racket/utils/struct-extraction.rkt | 13 + typed-racket-lib/typed/racket.rkt | 4 +- 12 files changed, 825 insertions(+), 594 deletions(-) create mode 100644 typed-racket-lib/typed-racket/base-env/ann-inst.rkt create mode 100644 typed-racket-lib/typed-racket/base-env/prims-contract.rkt create mode 100644 typed-racket-lib/typed-racket/base-env/prims-struct.rkt create mode 100644 typed-racket-lib/typed-racket/utils/struct-extraction.rkt diff --git a/typed-racket-lib/typed-racket/base-env/ann-inst.rkt b/typed-racket-lib/typed-racket/base-env/ann-inst.rkt new file mode 100644 index 00000000..0b99fa5f --- /dev/null +++ b/typed-racket-lib/typed-racket/base-env/ann-inst.rkt @@ -0,0 +1,39 @@ +#lang racket/base + +;; Forms for adding type annotations. + +;; This file is loaded by all Typed Racket programs, so it should not +;; have expensive runtime dependencies. + +(require (for-syntax syntax/parse "../private/syntax-properties.rkt" + racket/base) + "colon.rkt") + +(provide (for-syntax add-ann) ann inst) + +(define-syntax (ann stx) + (syntax-parse stx #:literals (:) + [(_ (~or (~seq arg : ty) (~seq arg ty))) + (add-ann #'arg #'ty)])) + +(define-for-syntax (add-ann expr-stx ty-stx) + (quasisyntax/loc expr-stx + (#,(type-ascription-property #'#%expression ty-stx) + #,expr-stx))) + +(define-syntax (inst stx) + (syntax-parse stx #:literals (:) + [(_ arg : . tys) + (syntax/loc stx (inst arg . tys))] + ;; FIXME: Is the right choice to use a #:row keyword or just + ;; to use a Row type constructor and keep it consistent? + [(_ arg #:row e ...) + (with-syntax ([expr (type-inst-property #'#%expression #'(#:row e ...))]) + (syntax/loc #'arg (expr arg)))] + [(_ arg tys ... ty ddd b:id) + #:when (eq? (syntax-e #'ddd) '...) + (with-syntax ([expr (type-inst-property #'#%expression #'(tys ... (ty . b)))]) + (syntax/loc #'arg (expr arg)))] + [(_ arg tys ...) + (with-syntax ([expr (type-inst-property #'#%expression #'(tys ...))]) + (syntax/loc #'arg (expr arg)))])) diff --git a/typed-racket-lib/typed-racket/base-env/base-types.rkt b/typed-racket-lib/typed-racket/base-env/base-types.rkt index 1f02b2c6..087a037f 100644 --- a/typed-racket-lib/typed-racket/base-env/base-types.rkt +++ b/typed-racket-lib/typed-racket/base-env/base-types.rkt @@ -1,6 +1,7 @@ #lang s-exp "type-env-lang.rkt" -(require "../types/abbrev.rkt" "../types/union.rkt" "../types/numeric-tower.rkt" "../rep/type-rep.rkt") +(require "../types/abbrev.rkt" "../types/union.rkt" + "../types/numeric-tower.rkt" "../rep/type-rep.rkt") [Complex -Number] [Number -Number] diff --git a/typed-racket-lib/typed-racket/base-env/class-prims.rkt b/typed-racket-lib/typed-racket/base-env/class-prims.rkt index fc23b76e..eba7306c 100644 --- a/typed-racket-lib/typed-racket/base-env/class-prims.rkt +++ b/typed-racket-lib/typed-racket/base-env/class-prims.rkt @@ -5,7 +5,6 @@ (require (prefix-in untyped: racket/class) "class-clauses.rkt" "colon.rkt" - "../typecheck/internal-forms.rkt" "../private/class-literals.rkt" "../utils/typed-method-property.rkt" (only-in "prims.rkt" [define tr:define]) @@ -18,6 +17,7 @@ syntax/kerncase syntax/parse syntax/stx + "../typecheck/internal-forms.rkt" "annotate-classes.rkt" "../private/syntax-properties.rkt" "../utils/disarm.rkt" diff --git a/typed-racket-lib/typed-racket/base-env/colon.rkt b/typed-racket-lib/typed-racket/base-env/colon.rkt index ef22bc08..ba6c7fb6 100644 --- a/typed-racket-lib/typed-racket/base-env/colon.rkt +++ b/typed-racket-lib/typed-racket/base-env/colon.rkt @@ -4,7 +4,7 @@ "../private/parse-classes.rkt" "../utils/disappeared-use.rkt" (only-in "../utils/tc-utils.rkt" tc-error/stx)) - "../typecheck/internal-forms.rkt" + (submod "../typecheck/internal-forms.rkt" forms) (prefix-in t: "base-types-extra.rkt")) (provide :) diff --git a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt new file mode 100644 index 00000000..f9791d6b --- /dev/null +++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt @@ -0,0 +1,438 @@ +#lang racket/base + +;; This file defines primitives that make use of contracts in their +;; expansion. This include `cast` and various forms of +;; `require/typed`. +;; +;; Additionally, the _implementations_ of these forms are lazily +;; loaded. This works as follows: +;; +;; - the forms themselves as defined (using `define-syntax`) in the +;; `forms` submodule +;; +;; - their implementations (under the same names) are defined at phase +;; 0 using `define` in the main module +;; +;; - the `forms` submodule uses `lazy-require` to load the +;; implementations of the forms + + +(provide require/opaque-type require-typed-struct-legacy require-typed-struct + require/typed-legacy require/typed require/typed/provide + require-typed-struct/provide cast make-predicate define-predicate) + +(module forms racket/base + (require (for-syntax racket/lazy-require racket/base)) + (begin-for-syntax + (lazy-require [(submod "..") + (require/opaque-type + require-typed-struct-legacy + require-typed-struct + require/typed-legacy require/typed require/typed/provide + require-typed-struct/provide cast make-predicate define-predicate)])) + (define-syntax (def stx) + (syntax-case stx () + [(_ id ...) + (with-syntax ([(names ...) (generate-temporaries #'(id ...))]) + #'(begin (provide (rename-out [names id] ...)) + (define-syntax (names stx) (id stx)) ...))])) + (def require/opaque-type + require-typed-struct-legacy + require-typed-struct + require/typed-legacy require/typed require/typed/provide + require-typed-struct/provide cast make-predicate define-predicate)) + +(require (for-template (submod "." forms) "../utils/require-contract.rkt" + (submod "../typecheck/internal-forms.rkt" forms) + "colon.rkt" + "top-interaction.rkt" + "base-types.rkt" + "base-types-extra.rkt" + "prims-struct.rkt" + syntax/location + (rename-in racket/contract/base [-> c->] [->* c->*] [case-> c:case->]))) + +(require racket/lazy-require + syntax/parse + syntax/stx + racket/syntax + unstable/syntax + racket/base + racket/struct-info + syntax/struct + syntax/location + "../utils/tc-utils.rkt" + "../private/syntax-properties.rkt" + "../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-template racket/base "ann-inst.rkt")) + +;; Lazily loaded b/c they're only used sometimes, so we save a lot +;; of loading by not having them when they are unneeded +(lazy-require ["../rep/type-rep.rkt" (make-Opaque Error?)] + ["../types/utils.rkt" (fv)] + [syntax/define (normalize-definition)] + [typed-racket/private/parse-type (parse-type)] + [typed-racket/env/type-alias-env (register-resolved-type-alias)]) + +(define (with-type* expr ty) + (with-type #`(ann #,expr #,ty))) + +(define (ignore-some/expr expr ty) + #`(#,(ignore-some-expr-property #'#%expression ty) #,expr)) + +(define-syntax-class opt-parent + #:attributes (nm parent) + (pattern nm:id #:with parent #'#f) + (pattern (nm:id parent:id))) + + +(define-values (require/typed-legacy require/typed) + (let () + (define-syntax-class opt-rename + #:attributes (nm spec) + (pattern nm:id + #:with spec #'nm) + (pattern (orig-nm:id internal-nm:id) + #:with spec #'(orig-nm internal-nm) + #:with nm #'internal-nm)) + + (define-syntax-class simple-clause + #:attributes (nm ty) + (pattern [nm:opt-rename ty])) + + (define-splicing-syntax-class (opt-constructor legacy struct-name) + #:attributes (value) + (pattern (~seq) + #:attr value (if legacy + #`(#:extra-constructor-name + #,(format-id struct-name "make-~a" struct-name)) + #'())) + (pattern (~seq (~and key (~or #:extra-constructor-name #:constructor-name)) name:id) + #:attr value #'(key name))) + + (define-syntax-class (struct-clause legacy) + ;#:literals (struct) + #:attributes (nm (body 1) (constructor-parts 1)) + (pattern [(~or (~datum struct) #:struct) + nm:opt-parent (body ...) + (~var constructor (opt-constructor legacy #'nm.nm))] + #:with (constructor-parts ...) #'constructor.value)) + + (define-syntax-class opaque-clause + ;#:literals (opaque) + #:attributes (ty pred opt) + (pattern [(~or (~datum opaque) #:opaque) ty:id pred:id] + #:with opt #'()) + (pattern [(~or (~datum opaque) #:opaque) opaque ty:id pred:id #:name-exists] + #:with opt #'(#:name-exists))) + + (define-syntax-class (clause legacy lib) + #:attributes (spec) + (pattern oc:opaque-clause #:attr spec + #`(require/opaque-type oc.ty oc.pred #,lib . oc.opt)) + (pattern (~var strc (struct-clause legacy)) #:attr spec + #`(require-typed-struct strc.nm (strc.body ...) strc.constructor-parts ... #,lib)) + (pattern sc:simple-clause #:attr spec + #`(require/typed #:internal sc.nm sc.ty #,lib))) + + + (define ((r/t-maker legacy) stx) + (syntax-parse stx + [(_ lib:expr (~var c (clause legacy #'lib)) ...) + (when (zero? (syntax-length #'(c ...))) + (raise-syntax-error #f "at least one specification is required" stx)) + #`(begin c.spec ...)] + [(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...) + (define/with-syntax hidden (generate-temporary #'nm.nm)) + (define/with-syntax sm (if (attribute parent) + #'(#:struct-maker parent) + #'())) + ;; define `cnt*` to be fixed up later by the module type-checking + (define cnt* + (syntax-local-lift-expression + (make-contract-def-rhs #'ty #f (attribute parent)))) + (quasisyntax/loc stx + (begin + #,(internal #'(require/typed-internal hidden ty . sm)) + #,(ignore #`(require/contract nm.spec hidden #,cnt* lib))))])) + (values (r/t-maker #t) (r/t-maker #f)))) + + +(define (require/typed/provide stx) + (unless (memq (syntax-local-context) '(module module-begin)) + (raise-syntax-error 'require/typed/provide + "can only be used at module top-level")) + (syntax-parse stx + [(_ lib) #'(begin)] + [(_ lib [r:id t] other-clause ...) + #'(begin (require/typed lib [r t]) + (provide r) + (require/typed/provide lib other-clause ...))] + [(_ lib (~and clause [#:struct name:id ([f:id (~datum :) t] ...) + option ...]) + other-clause ...) + #'(begin (require/typed lib clause) + (provide (struct-out name)) + (require/typed/provide lib other-clause ...))] + [(_ lib (~and clause [#:struct (name:id parent:id) + ([f:id (~datum :) t] ...) + option ...]) + other-clause ...) + #'(begin (require/typed lib clause) + (provide (struct-out name)) + (require/typed/provide lib other-clause ...))] + [(_ lib (~and clause [#:opaque t:id pred:id]) + other-clause ...) + #'(begin (require/typed lib clause) + (provide t pred) + (require/typed/provide lib other-clause ...))])) + + +(define require-typed-struct/provide + (syntax-rules () + [(_ (nm par) . rest) + (begin (require-typed-struct (nm par) . rest) + (provide (struct-out nm)))] + [(_ nm . rest) + (begin (require-typed-struct nm . rest) + (provide (struct-out nm)))])) + +;; Conversion of types to contracts +;; define-predicate +;; make-predicate +;; cast + +;; Helper to construct syntax for contract definitions +(define (make-contract-def-rhs type flat? maker?) + (contract-def-property #'#f `#s(contract-def ,type ,flat? ,maker? untyped))) + +(define (define-predicate stx) + (syntax-parse stx + [(_ name:id ty:expr) + #`(begin + ;; We want the value bound to name to have a nice object name. Using the built in mechanism + ;; of define has better performance than procedure-rename. + #,(ignore + #'(define name + (let ([pred (make-predicate ty)]) + (lambda (x) (pred x))))) + ;; not a require, this is just the unchecked declaration syntax + #,(internal #'(require/typed-internal name (Any -> Boolean : ty))))])) + + +(define (make-predicate stx) + (syntax-parse stx + [(_ ty:expr) + (define name (syntax-local-lift-expression + (make-contract-def-rhs #'ty #t #f))) + (define (check-valid-type _) + (define type (parse-type #'ty)) + (define vars (fv type)) + ;; If there was an error don't create another one + (unless (or (Error? type) (null? vars)) + (tc-error/delayed + "Type ~a could not be converted to a predicate because it contains free variables." + type))) + #`(#,(external-check-property #'#%expression check-valid-type) + #,(ignore-some/expr #`(flat-contract-predicate #,name) #'(Any -> Boolean : ty)))])) + + +(define (cast stx) + (syntax-parse stx + [(_ v:expr ty:expr) + (define (apply-contract ctc-expr) + #`(#%expression + #,(ignore-some/expr + #`(let-values (((val) #,(with-type* #'v #'Any))) + #,(syntax-property + (quasisyntax/loc stx + (contract + #,ctc-expr + val + 'cast + 'typed-world + val + (quote-srcloc #,stx))) + 'feature-profile:TR-dynamic-check #t)) + #'ty))) + + (cond [(not (unbox typed-context?)) ; no-check, don't check + #'v] + [else + (define ctc (syntax-local-lift-expression + (make-contract-def-rhs #'ty #f #f))) + (define (check-valid-type _) + (define type (parse-type #'ty)) + (define vars (fv type)) + ;; If there was an error don't create another one + (unless (or (Error? type) (null? vars)) + (tc-error/delayed + "Type ~a could not be converted to a contract because it contains free variables." + type))) + #`(#,(external-check-property #'#%expression check-valid-type) + #,(apply-contract ctc))])])) + + + +(define (require/opaque-type stx) + (define-syntax-class name-exists-kw + (pattern #:name-exists)) + (syntax-parse stx + [(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...) + ;; This line appears redundant with the use of `define-type-alias` below, but + ;; it's actually necessary for top-level uses because this opaque type may appear + ;; in subsequent `require/typed` clauses, which needs to parse the types at + ;; expansion-time, not at typechecking time when aliases are installed. + (register-resolved-type-alias #'ty (make-Opaque #'pred)) + (with-syntax ([hidden (generate-temporary #'pred)]) + (quasisyntax/loc stx + (begin + #,(ignore #'(define pred-cnt (any/c . c-> . boolean?))) + #,(internal #'(require/typed-internal hidden (Any -> Boolean : (Opaque pred)))) + #,(if (attribute ne) + (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) + (syntax/loc stx (define-type-alias ty (Opaque pred)))) + #,(ignore #'(require/contract pred hidden pred-cnt lib)))))])) + + + +(module self-ctor racket/base + (require racket/struct-info) + + ;Copied from racket/private/define-struct + ;FIXME when multiple bindings are supported + (define (self-ctor-transformer orig stx) + (define (transfer-srcloc orig stx) + (datum->syntax orig (syntax-e orig) stx orig)) + (syntax-case stx () + [(self arg ...) (datum->syntax stx + (cons (syntax-property (transfer-srcloc orig #'self) + 'constructor-for + (syntax-local-introduce #'self)) + (syntax-e (syntax (arg ...)))) + stx + stx)] + [_ (transfer-srcloc orig stx)])) + (define make-struct-info-self-ctor + (let () + (struct struct-info-self-ctor (id info) + #:property prop:procedure + (lambda (ins stx) + (self-ctor-transformer (struct-info-self-ctor-id ins) stx)) + #:property prop:struct-info (λ (x) (extract-struct-info (struct-info-self-ctor-info x)))) + struct-info-self-ctor)) + (provide make-struct-info-self-ctor)) + +(require (submod "." self-ctor)) + + + +(define-values (require-typed-struct-legacy require-typed-struct) + (let () + + (define-splicing-syntax-class (constructor-term legacy struct-name) + (pattern (~seq) #:fail-when legacy #f #:attr name struct-name #:attr extra #f) + (pattern (~seq) #:fail-unless legacy #f #:attr name (format-id struct-name "make-~a" struct-name) + #:attr extra #t) + (pattern (~seq #:constructor-name name:id) #:attr extra #f) + (pattern (~seq #:extra-constructor-name name:id) #:attr extra #t)) + + + (define ((rts legacy) stx) + (syntax-parse stx #:literals (:) + [(_ name:opt-parent ([fld : ty] ...) (~var input-maker (constructor-term legacy #'name.nm)) lib) + (with-syntax* ([nm #'name.nm] + [parent #'name.parent] + [hidden (generate-temporary #'name.nm)] + [orig-struct-info (generate-temporary #'nm)] + [spec (if (syntax-e #'name.parent) #'(nm parent) #'nm)] + [num-fields (syntax-length #'(fld ...))] + [(type-des _ pred sel ...) + (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] + [(mut ...) (stx-map (lambda _ #'#f) #'(sel ...))] + [maker-name #'input-maker.name] + ;maker-name's symbolic form is used in the require form + [id-is-ctor? (or (attribute input-maker.extra) + (bound-identifier=? #'maker-name #'nm))] + ;Only used if id-is-ctor? is true + [internal-maker (generate-temporary #'maker-name)] + ;The actual identifier bound to the constructor + [real-maker (if (syntax-e #'id-is-ctor?) #'internal-maker #'maker-name)] + [extra-maker (and (attribute input-maker.extra) + (not (bound-identifier=? #'make-name #'nm)) + #'maker-name)]) + (define (maybe-add-quote-syntax stx) + (if (and stx (syntax-e stx)) #`(quote-syntax #,stx) stx)) + + (quasisyntax/loc stx + (begin + (require (only-in lib type-des (nm orig-struct-info))) + + (define-for-syntax si + (let () + (define-values (orig-type-des orig-maker orig-pred + orig-sels orig-muts orig-parent) + (apply values (extract-struct-info/checked + (quote-syntax orig-struct-info)))) + + (define (id-drop sels muts num) + (cond + [(zero? num) (values sels muts)] + [(null? sels) (int-err "id-drop: Too short of list")] + [(pair? sels) + (cond + [(not (car sels)) (values sels muts)] + [else (id-drop (cdr sels) (cdr muts) (sub1 num))])] + [else (int-err "id-drop: Not a list")])) + + (define (struct-info-list new-sels new-muts) + (list (quote-syntax type-des) + (quote-syntax real-maker) + (quote-syntax pred) + (append (list #,@(map maybe-add-quote-syntax + (reverse (syntax->list #'(sel ...))))) + new-sels) + (append (list #,@(map maybe-add-quote-syntax + (reverse (syntax->list #'(mut ...))))) + new-muts) + orig-parent)) + + (make-struct-info + (lambda () + #,(if (syntax-e #'parent) + (let-values (((parent-type-des parent-maker parent-pred + parent-sel parent-mut grand-parent) + (apply values + (extract-struct-info/checked #'parent)))) + #`(struct-info-list + (list #,@(map maybe-add-quote-syntax parent-sel)) + (list #,@(map maybe-add-quote-syntax parent-mut)))) + #`(let-values (((new-sels new-muts) + (id-drop orig-sels orig-muts num-fields))) + (struct-info-list new-sels new-muts))))))) + + (define-syntax nm + (if id-is-ctor? + (make-struct-info-self-ctor #'internal-maker si) + si)) + + (dtsi* () spec ([fld : ty] ...) #:maker maker-name #:type-only) + #,(ignore #'(require/contract pred hidden (any/c . c-> . boolean?) lib)) + #,(internal #'(require/typed-internal hidden (Any -> Boolean : nm))) + (require/typed #:internal (maker-name real-maker) nm lib + #:struct-maker parent) + + ;This needs to be a different identifier to meet the specifications + ;of struct (the id constructor shouldn't expand to it) + #,(if (syntax-e #'extra-maker) + #'(require/typed #:internal (maker-name extra-maker) nm lib + #:struct-maker parent) + #'(begin)) + + (require/typed lib + [sel (nm -> ty)]) ...)))])) + + (values (rts #t) (rts #f)))) diff --git a/typed-racket-lib/typed-racket/base-env/prims-struct.rkt b/typed-racket-lib/typed-racket/base-env/prims-struct.rkt new file mode 100644 index 00000000..53880297 --- /dev/null +++ b/typed-racket-lib/typed-racket/base-env/prims-struct.rkt @@ -0,0 +1,211 @@ +#lang racket/base + +;; This module defines the forms needed for defining structs in Typed +;; Racket. The forms here are referenced in and re-provided by +;; "prims.rkt", sometimes under other names. + +;; This file is `require`d into all Typed Racket programs, and thus +;; its runtime dependencies should be kept to a minimum. In +;; particular, contracts and `syntax-parse` are both to be avoided as +;; runtime dependencies (syntax time is fine). + +(require (submod "../typecheck/internal-forms.rkt" forms) + "colon.rkt" + "base-types-extra.rkt" + "ann-inst.rkt" + (for-syntax racket/base syntax/parse + racket/lazy-require + syntax/parse/experimental/template + syntax/stx + racket/list + racket/syntax + unstable/sequence + unstable/syntax + racket/struct-info + syntax/struct + "../typecheck/internal-forms.rkt" + "annotate-classes.rkt" + "../private/parse-classes.rkt" + "../private/syntax-properties.rkt" + "../typecheck/internal-forms.rkt")) + +(provide define-typed-struct -struct define-typed-struct/exec define-type-alias dtsi* dtsi/exec*) + +(define-for-syntax (with-type* expr ty) + (with-type #`(ann #,expr #,ty))) + +;; Syntax classes and helpers for `struct:` +(begin-for-syntax + (define-syntax-class fld-spec + #:literals (:) + #:description "[field-name : type]" + (pattern [fld:id : ty] + #:with form this-syntax) + (pattern fld:id + #:fail-when #t + (format "field `~a' requires a type annotation" + (syntax-e #'fld)) + #:with form 'dummy)) + + (define-syntax-class struct-name + #:description "struct name (with optional super-struct name)" + #:attributes (name super) + (pattern (name:id super:id)) + (pattern name:id + #:with super #f)) + + (define-splicing-syntax-class struct-name/new + #:description "struct name (with optional super-struct name)" + (pattern (~seq name:id super:id) + #:attr old-spec #'(name super) + #:with new-spec #'(name super)) + (pattern name:id + #:with super #f + #:attr old-spec #'name + #:with new-spec #'(name))) + + (define-splicing-syntax-class maybe-type-vars + #:description "optional list of type variables" + #:attributes ((vars 1)) + (pattern (vars:id ...)) + (pattern (~seq) #:attr (vars 1) null)) + + (define-splicing-syntax-class struct-options + #:description "typed structure type options" + #:attributes (guard mutable? transparent? prefab? [prop 1] [prop-val 1]) + (pattern (~seq (~or (~optional (~seq (~and #:mutable mutable?))) + (~optional (~seq (~and #:transparent transparent?))) + (~optional (~seq (~and #:prefab prefab?))) + ;; FIXME: unsound, but relied on in core libraries + ;; #:guard ought to be supportable with some work + ;; #:property is harder + (~optional (~seq #:guard guard:expr)) + (~seq #:property prop:expr prop-val:expr)) + ...))) + + (define-syntax-class dtsi-struct-name + #:description "struct name (with optional super-struct name)" + #:attributes (name super value) + (pattern ((~var name (static struct-info? "struct name")) super:id) + #:attr value (attribute name.value)) + (pattern (~var name (static struct-info? "struct name")) + #:attr value (attribute name.value) + #:with super #f))) + +(define-syntax (define-typed-struct/exec stx) + (syntax-parse stx #:literals (:) + [(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty]) + (with-syntax* + ([proc* (with-type* #'proc #'proc-ty)] + [d-s (ignore-some (syntax/loc stx (define-struct nm (fld.name ...) + #:property prop:procedure proc*)))] + [dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))]) + #'(begin d-s dtsi))])) + +(define-syntaxes (dtsi* dtsi/exec*) + (let () + (define (mk internal-id) + (lambda (stx) + (syntax-parse stx + [(_ () nm:dtsi-struct-name . rest) + (internal (quasisyntax/loc stx + (#,internal-id + #,(struct-info-property #'nm (attribute nm.value)) . rest)))] + [(_ (vars:id ...) nm:dtsi-struct-name . rest) + (internal (quasisyntax/loc stx + (#,internal-id (vars ...) + #,(struct-info-property #'nm (attribute nm.value)) . rest)))]))) + (values (mk #'define-typed-struct-internal) + (mk #'define-typed-struct/exec-internal)))) + + + +;; User-facing macros for defining typed structure types +(define-syntaxes (define-typed-struct -struct) + (values + (lambda (stx) + (syntax-parse stx + [(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...) + opts:struct-options) + (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())] + [cname (second (build-struct-names #'nm.name null #t #t))]) + (with-syntax ([d-s (ignore-some + (syntax/loc stx (define-struct nm (fs.fld ...) . opts)))] + [dtsi (quasisyntax/loc stx + (dtsi* (vars.vars ...) nm (fs.form ...) + #:maker #,cname + #,@mutable?))]) + (if (eq? (syntax-local-context) 'top-level) + ;; Use `eval` at top-level to avoid an unbound id error + ;; from dtsi trying to look at the d-s bindings. + #'(begin (eval (quote-syntax d-s)) + ;; It is important here that the object under the + ;; eval is a quasiquoted literal in order + ;; for #%top-interaction to get the lexical + ;; information for TR's actual #%top-interaction. + ;; This effectively lets us invoke the type-checker + ;; dynamically. + ;; + ;; The quote-syntax is also important because we want + ;; the `dtsi` to have the lexical information from + ;; this module. This ensures that the `dtsi` macro + ;; is actually bound to its definition above. + (eval `(#%top-interaction . ,(quote-syntax dtsi)))) + #'(begin d-s dtsi))))])) + (lambda (stx) + (syntax-parse stx + [(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...) + opts:struct-options) + (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())] + [prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())]) + (with-syntax ([d-s (ignore (quasisyntax/loc stx + (struct #,@(attribute nm.new-spec) (fs.fld ...) + . opts)))] + [dtsi (quasisyntax/loc stx + (dtsi* (vars.vars ...) + nm.old-spec (fs.form ...) + #,@mutable? + #,@prefab?))]) + ;; see comment above + (if (eq? (syntax-local-context) 'top-level) + #'(begin (eval (quote-syntax d-s)) + (eval `(#%top-interaction . ,(quote-syntax dtsi)))) + #'(begin d-s dtsi))))])))) + + +;; this has to live here because it's used below +(define-syntax (define-type-alias stx) + (define-syntax-class all-vars + #:literals (All) + #:attributes (poly-vars) + (pattern (All (arg:id ...) rest) + #:with poly-vars #'(arg ...)) + (pattern type:expr #:with poly-vars #'#f)) + + (define-splicing-syntax-class omit-define-syntaxes + #:attributes (omit) + (pattern #:omit-define-syntaxes #:attr omit #t) + (pattern (~seq) #:attr omit #f)) + + (define-splicing-syntax-class type-alias-full + #:attributes (tname type poly-vars omit) + (pattern (~seq tname:id (~and type:expr :all-vars) :omit-define-syntaxes)) + (pattern (~seq (tname:id arg:id ...) body:expr :omit-define-syntaxes) + #:with poly-vars #'(arg ...) + #:with type (syntax/loc #'body (All (arg ...) body)))) + + (syntax-parse stx + [(_ :type-alias-full) + (define/with-syntax stx-err-fun + #'(lambda (stx) + (raise-syntax-error + 'type-check + "type name used out of context" + stx + (and (stx-pair? stx) (stx-car stx))))) + #`(begin + #,(if (not (attribute omit)) + (ignore #'(define-syntax tname stx-err-fun)) + #'(begin)) + #,(internal (syntax/loc stx + (define-type-alias-internal tname type poly-vars))))])) diff --git a/typed-racket-lib/typed-racket/base-env/prims.rkt b/typed-racket-lib/typed-racket/base-env/prims.rkt index 3cf7d6a8..c2c20958 100644 --- a/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -24,16 +24,23 @@ the typed racket language. 3. contracted versions of built-in racket values such as parameters and prompt tags that are defined in "base-contracted.rkt" + These are implemented using indirection so that contracts aren't loaded at runtime unless + needed. + |# -(provide (except-out (all-defined-out) dtsi* dtsi/exec* -let-internal define-for-variants define-for*-variants - with-handlers: define-for/acc:-variants base-for/flvector: base-for/vector - -lambda -define -do -let -let* -let*-values -let-values -let/cc -let/ec -letrec -letrec-values -struct) - ;; provide the contracted bindings as primitives - (all-from-out "base-contracted.rkt") +(provide (except-out (all-defined-out) -let-internal define-for-variants + define-for*-variants with-handlers: define-for/acc:-variants + base-for/flvector: base-for/vector -lambda -define -do -let + -let* -let*-values -let-values -let/cc -let/ec -letrec -letrec-values) (all-from-out "top-interaction.rkt") (all-from-out "case-lambda.rkt") + (all-from-out (submod "prims-contract.rkt" forms)) + define-type-alias + define-typed-struct + define-typed-struct/exec + ann inst : (rename-out [define-typed-struct define-struct:] [define-typed-struct define-struct] @@ -71,7 +78,6 @@ the typed racket language. [for/first: for/first] [for/last: for/last] [for/fold: for/fold] - [for/set: for/set] [for*: for*] [for*/list: for*/list] [for*/lists: for*/lists] @@ -86,6 +92,7 @@ the typed racket language. [for*/first: for*/first] [for*/last: for*/last] [for*/fold: for*/fold] + [for/set: for/set] [for*/set: for*/set] [-do do] [-do do:] @@ -93,29 +100,20 @@ the typed racket language. [define-typed-struct/exec define-struct/exec:] [define-typed-struct/exec define-struct/exec])) -(module struct-extraction racket/base - (provide extract-struct-info/checked) - (require syntax/parse racket/struct-info) - (define (extract-struct-info/checked id) - (syntax-parse id - [(~var id (static struct-info? "identifier bound to a structure type")) - (extract-struct-info (syntax-local-value #'id))]))) - -(require "../utils/require-contract.rkt" - "colon.rkt" - "../typecheck/internal-forms.rkt" - (rename-in racket/contract/base [-> c->] [->* c->*] [case-> c:case->]) - ;; contracted bindings to replace built-in ones - "base-contracted.rkt" +(require "colon.rkt" "top-interaction.rkt" "base-types.rkt" "base-types-extra.rkt" "case-lambda.rkt" - 'struct-extraction - racket/set + "prims-struct.rkt" + "ann-inst.rkt" + racket/unsafe/ops racket/flonum ; for for/flvector and for*/flvector racket/extflonum ; for for/extflvector and for*/extflvector - syntax/location + (only-in "../types/numeric-predicates.rkt" index?) + (submod "../typecheck/internal-forms.rkt" forms) + (submod "prims-contract.rkt" forms) + ;; for binding comparisons (for-label (only-in "base-types-extra.rkt" Values) (only-in racket/base values)) (for-syntax @@ -130,19 +128,33 @@ the typed racket language. racket/base racket/struct-info syntax/struct + (only-in "../typecheck/internal-forms.rkt" internal) "annotate-classes.rkt" - "../utils/tc-utils.rkt" "../utils/literal-syntax-class.rkt" "../private/parse-classes.rkt" "../private/syntax-properties.rkt" - ;"../types/utils.rkt" - "for-clauses.rkt" - 'struct-extraction) - "../types/numeric-predicates.rkt" - racket/unsafe/ops - racket/vector) + "for-clauses.rkt")) + (provide index?) ; useful for assert, and racket doesn't have it + +;; This section reprovides (using the same submodule technique as for +;; contracted bindings in typed modules) values that are contracted +;; for _all_ typed programs. +(module+ #%contract-defs + (require "base-contracted.rkt") + (provide (all-from-out "base-contracted.rkt"))) + +(begin-for-syntax + (require racket/base "../utils/redirect-contract.rkt") + (define varref (#%variable-reference)) + (define mk (make-make-redirect-to-contract varref))) + +(define-syntax-rule (def-redirect id ...) + (begin (define-syntax id (mk (quote-syntax id))) ... (provide id ...))) + +(def-redirect default-continuation-prompt-tag) + ;; Lazily loaded b/c they're only used sometimes, so we save a lot ;; of loading by not having them when they are unneeded (begin-for-syntax @@ -154,213 +166,6 @@ the typed racket language. (define-for-syntax (with-type* expr ty) (with-type #`(ann #,expr #,ty))) -(define-for-syntax (ignore-some/expr expr ty) - #`(#,(ignore-some-expr-property #'#%expression ty) #,expr)) - - -(begin-for-syntax - (define-syntax-class opt-parent - #:attributes (nm parent) - (pattern nm:id #:with parent #'#f) - (pattern (nm:id parent:id)))) - - -(define-syntaxes (require/typed-legacy require/typed) - (let () - (define-syntax-class opt-rename - #:attributes (nm spec) - (pattern nm:id - #:with spec #'nm) - (pattern (orig-nm:id internal-nm:id) - #:with spec #'(orig-nm internal-nm) - #:with nm #'internal-nm)) - - (define-syntax-class simple-clause - #:attributes (nm ty) - (pattern [nm:opt-rename ty])) - - (define-splicing-syntax-class (opt-constructor legacy struct-name) - #:attributes (value) - (pattern (~seq) #:attr value (if legacy - #`(#:extra-constructor-name #,(format-id struct-name "make-~a" struct-name)) - #'())) - (pattern (~seq (~and key (~or #:extra-constructor-name #:constructor-name)) name:id) #:attr value #'(key name))) - - (define-syntax-class (struct-clause legacy) - ;#:literals (struct) - #:attributes (nm (body 1) (constructor-parts 1)) - (pattern [(~or (~datum struct) #:struct) nm:opt-parent (body ...) (~var constructor (opt-constructor legacy #'nm.nm))] - #:with (constructor-parts ...) #'constructor.value)) - - (define-syntax-class opaque-clause - ;#:literals (opaque) - #:attributes (ty pred opt) - (pattern [(~or (~datum opaque) #:opaque) ty:id pred:id] - #:with opt #'()) - (pattern [(~or (~datum opaque) #:opaque) opaque ty:id pred:id #:name-exists] - #:with opt #'(#:name-exists))) - - (define-syntax-class (clause legacy lib) - #:attributes (spec) - (pattern oc:opaque-clause #:attr spec - #`(require/opaque-type oc.ty oc.pred #,lib . oc.opt)) - (pattern (~var strc (struct-clause legacy)) #:attr spec - #`(require-typed-struct strc.nm (strc.body ...) strc.constructor-parts ... #,lib)) - (pattern sc:simple-clause #:attr spec - #`(require/typed #:internal sc.nm sc.ty #,lib))) - - - (define ((r/t-maker legacy) stx) - (syntax-parse stx - [(_ lib:expr (~var c (clause legacy #'lib)) ...) - (when (zero? (syntax-length #'(c ...))) - (raise-syntax-error #f "at least one specification is required" stx)) - #`(begin c.spec ...)] - [(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...) - (define/with-syntax hidden (generate-temporary #'nm.nm)) - (define/with-syntax sm (if (attribute parent) - #'(#:struct-maker parent) - #'())) - ;; define `cnt*` to be fixed up later by the module type-checking - (define cnt* - (syntax-local-lift-expression - (make-contract-def-rhs #'ty #f (attribute parent)))) - (quasisyntax/loc stx - (begin - #,(internal #'(require/typed-internal hidden ty . sm)) - #,(ignore #`(require/contract nm.spec hidden #,cnt* lib))))])) - (values (r/t-maker #t) (r/t-maker #f)))) - -(define-syntax (require/typed/provide stx) - (unless (memq (syntax-local-context) '(module module-begin)) - (raise-syntax-error 'require/typed/provide - "can only be used at module top-level")) - (syntax-parse stx - [(_ lib) #'(begin)] - [(_ lib [r:id t] other-clause ...) - #'(begin (require/typed lib [r t]) - (provide r) - (require/typed/provide lib other-clause ...))] - [(_ lib (~and clause [#:struct name:id ([f:id (~datum :) t] ...) - option ...]) - other-clause ...) - #'(begin (require/typed lib clause) - (provide (struct-out name)) - (require/typed/provide lib other-clause ...))] - [(_ lib (~and clause [#:struct (name:id parent:id) - ([f:id (~datum :) t] ...) - option ...]) - other-clause ...) - #'(begin (require/typed lib clause) - (provide (struct-out name)) - (require/typed/provide lib other-clause ...))] - [(_ lib (~and clause [#:opaque t:id pred:id]) - other-clause ...) - #'(begin (require/typed lib clause) - (provide t pred) - (require/typed/provide lib other-clause ...))])) - -(define-syntax require-typed-struct/provide - (syntax-rules () - [(_ (nm par) . rest) - (begin (require-typed-struct (nm par) . rest) - (provide (struct-out nm)))] - [(_ nm . rest) - (begin (require-typed-struct nm . rest) - (provide (struct-out nm)))])) - -;; Conversion of types to contracts -;; define-predicate -;; make-predicate -;; cast - -;; Helper to construct syntax for contract definitions -(define-for-syntax (make-contract-def-rhs type flat? maker?) - (contract-def-property #'#f `#s(contract-def ,type ,flat? ,maker? untyped))) - -(define-syntax (define-predicate stx) - (syntax-parse stx - [(_ name:id ty:expr) - #`(begin - ;; We want the value bound to name to have a nice object name. Using the built in mechanism - ;; of define has better performance than procedure-rename. - #,(ignore - #'(define name - (let ([pred (make-predicate ty)]) - (lambda (x) (pred x))))) - ;; not a require, this is just the unchecked declaration syntax - #,(internal #'(require/typed-internal name (Any -> Boolean : ty))))])) - -(define-syntax (make-predicate stx) - (syntax-parse stx - [(_ ty:expr) - (define name (syntax-local-lift-expression - (make-contract-def-rhs #'ty #t #f))) - (define (check-valid-type _) - (define type (parse-type #'ty)) - (define vars (fv type)) - ;; If there was an error don't create another one - (unless (or (Error? type) (null? vars)) - (tc-error/delayed - "Type ~a could not be converted to a predicate because it contains free variables." - type))) - #`(#,(external-check-property #'#%expression check-valid-type) - #,(ignore-some/expr #`(flat-contract-predicate #,name) #'(Any -> Boolean : ty)))])) - -(define-syntax (cast stx) - (syntax-parse stx - [(_ v:expr ty:expr) - (define (apply-contract ctc-expr) - #`(#%expression - #,(ignore-some/expr - #`(let-values (((val) #,(with-type* #'v #'Any))) - #,(syntax-property - (quasisyntax/loc stx - (contract - #,ctc-expr - val - 'cast - 'typed-world - val - (quote-srcloc #,stx))) - 'feature-profile:TR-dynamic-check #t)) - #'ty))) - - (cond [(not (unbox typed-context?)) ; no-check, don't check - #'v] - [else - (define ctc (syntax-local-lift-expression - (make-contract-def-rhs #'ty #f #f))) - (define (check-valid-type _) - (define type (parse-type #'ty)) - (define vars (fv type)) - ;; If there was an error don't create another one - (unless (or (Error? type) (null? vars)) - (tc-error/delayed - "Type ~a could not be converted to a contract because it contains free variables." - type))) - #`(#,(external-check-property #'#%expression check-valid-type) - #,(apply-contract ctc))])])) - -(define-syntax (require/opaque-type stx) - (define-syntax-class name-exists-kw - (pattern #:name-exists)) - (syntax-parse stx - [(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...) - ;; This line appears redundant with the use of `define-type-alias` below, but - ;; it's actually necessary for top-level uses because this opaque type may appear - ;; in subsequent `require/typed` clauses, which needs to parse the types at - ;; expansion-time, not at typechecking time when aliases are installed. - (register-resolved-type-alias #'ty (make-Opaque #'pred)) - (with-syntax ([hidden (generate-temporary #'pred)]) - (quasisyntax/loc stx - (begin - #,(ignore #'(define pred-cnt (any/c . c-> . boolean?))) - #,(internal #'(require/typed-internal hidden (Any -> Boolean : (Opaque pred)))) - #,(if (attribute ne) - (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) - (syntax/loc stx (define-type-alias ty (Opaque pred)))) - #,(ignore #'(require/contract pred hidden pred-cnt lib)))))])) (define-syntax (plambda: stx) (syntax-parse stx @@ -385,34 +190,6 @@ the typed racket language. (: nm : type) (define (nm . formals.ann-formals) . body))))])) -(define-syntax (ann stx) - (syntax-parse stx #:literals (:) - [(_ (~or (~seq arg : ty) (~seq arg ty))) - (add-ann #'arg #'ty)])) - -(define-for-syntax (add-ann expr-stx ty-stx) - (quasisyntax/loc expr-stx - (#,(type-ascription-property #'#%expression ty-stx) - #,expr-stx))) - - -(define-syntax (inst stx) - (syntax-parse stx #:literals (:) - [(_ arg : . tys) - (syntax/loc stx (inst arg . tys))] - ;; FIXME: Is the right choice to use a #:row keyword or just - ;; to use a Row type constructor and keep it consistent? - [(_ arg #:row e ...) - (with-syntax ([expr (type-inst-property #'#%expression #'(#:row e ...))]) - (syntax/loc #'arg (expr arg)))] - [(_ arg tys ... ty ddd b:id) - #:when (eq? (syntax-e #'ddd) '...) - (with-syntax ([expr (type-inst-property #'#%expression #'(tys ... (ty . b)))]) - (syntax/loc #'arg (expr arg)))] - [(_ arg tys ...) - (with-syntax ([expr (type-inst-property #'#%expression #'(tys ...))]) - (syntax/loc #'arg (expr arg)))])) - (define-syntax (lambda: stx) (syntax-parse stx [(lambda: formals:annotated-formals . body) @@ -487,42 +264,6 @@ the typed racket language. (syntax/loc stx ((plambda: (A ...) (bn ...) . body) e ...))])) -(define-syntax (define-type-alias stx) - (define-syntax-class all-vars - #:literals (All) - #:attributes (poly-vars) - (pattern (All (arg:id ...) rest) - #:with poly-vars #'(arg ...)) - (pattern type:expr #:with poly-vars #'#f)) - - (define-splicing-syntax-class omit-define-syntaxes - #:attributes (omit) - (pattern #:omit-define-syntaxes #:attr omit #t) - (pattern (~seq) #:attr omit #f)) - - (define-splicing-syntax-class type-alias-full - #:attributes (tname type poly-vars omit) - (pattern (~seq tname:id (~and type:expr :all-vars) :omit-define-syntaxes)) - (pattern (~seq (tname:id arg:id ...) body:expr :omit-define-syntaxes) - #:with poly-vars #'(arg ...) - #:with type (syntax/loc #'body (All (arg ...) body)))) - - (syntax-parse stx - [(_ :type-alias-full) - (define/with-syntax stx-err-fun - #'(lambda (stx) - (raise-syntax-error - 'type-check - "type name used out of context" - stx - (and (stx-pair? stx) (stx-car stx))))) - #`(begin - #,(if (not (attribute omit)) - (ignore #'(define-syntax tname stx-err-fun)) - #'(begin)) - #,(internal (syntax/loc stx - (define-type-alias-internal tname type poly-vars))))])) - (define-syntax (with-handlers: stx) (syntax-parse stx [(_ ([pred? action] ...) . body) @@ -536,265 +277,6 @@ the typed racket language. (exn-handlers (quasisyntax/loc stx (with-handlers ([pred?* action*] ...) body*))))])) -(begin-for-syntax - (define-syntax-class dtsi-struct-name - #:description "struct name (with optional super-struct name)" - #:attributes (name super value) - (pattern ((~var name (static struct-info? "struct name")) super:id) - #:attr value (attribute name.value)) - (pattern (~var name (static struct-info? "struct name")) - #:attr value (attribute name.value) - #:with super #f))) - -(define-syntax (define-typed-struct/exec stx) - (syntax-parse stx #:literals (:) - [(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty]) - (with-syntax* - ([proc* (with-type* #'proc #'proc-ty)] - [d-s (ignore-some (syntax/loc stx (define-struct nm (fld.name ...) - #:property prop:procedure proc*)))] - [dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))]) - #'(begin d-s dtsi))])) - -(define-syntaxes (dtsi* dtsi/exec*) - (let () - (define (mk internal-id) - (lambda (stx) - (syntax-parse stx - [(_ () nm:dtsi-struct-name . rest) - (internal (quasisyntax/loc stx - (#,internal-id - #,(struct-info-property #'nm (attribute nm.value)) . rest)))] - [(_ (vars:id ...) nm:dtsi-struct-name . rest) - (internal (quasisyntax/loc stx - (#,internal-id (vars ...) - #,(struct-info-property #'nm (attribute nm.value)) . rest)))]))) - (values (mk #'define-typed-struct-internal) - (mk #'define-typed-struct/exec-internal)))) - -;; Syntax classes and helpers for `struct:` -(begin-for-syntax - (define-syntax-class fld-spec - #:literals (:) - #:description "[field-name : type]" - (pattern [fld:id : ty] - #:with form this-syntax) - (pattern fld:id - #:fail-when #t - (format "field `~a' requires a type annotation" - (syntax-e #'fld)) - #:with form 'dummy)) - - (define-syntax-class struct-name - #:description "struct name (with optional super-struct name)" - #:attributes (name super) - (pattern (name:id super:id)) - (pattern name:id - #:with super #f)) - - (define-splicing-syntax-class struct-name/new - #:description "struct name (with optional super-struct name)" - (pattern (~seq name:id super:id) - #:attr old-spec #'(name super) - #:with new-spec #'(name super)) - (pattern name:id - #:with super #f - #:attr old-spec #'name - #:with new-spec #'(name))) - - (define-splicing-syntax-class maybe-type-vars - #:description "optional list of type variables" - #:attributes ((vars 1)) - (pattern (vars:id ...)) - (pattern (~seq) #:attr (vars 1) null)) - - (define-splicing-syntax-class struct-options - #:description "typed structure type options" - #:attributes (guard mutable? transparent? prefab? [prop 1] [prop-val 1]) - (pattern (~seq (~or (~optional (~seq (~and #:mutable mutable?))) - (~optional (~seq (~and #:transparent transparent?))) - (~optional (~seq (~and #:prefab prefab?))) - ;; FIXME: unsound, but relied on in core libraries - ;; #:guard ought to be supportable with some work - ;; #:property is harder - (~optional (~seq #:guard guard:expr)) - (~seq #:property prop:expr prop-val:expr)) - ...)))) - -;; User-facing macros for defining typed structure types -(define-syntaxes (define-typed-struct -struct) - (values - (lambda (stx) - (syntax-parse stx - [(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...) - opts:struct-options) - (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())] - [cname (second (build-struct-names #'nm.name empty #t #t))]) - (with-syntax ([d-s (ignore-some - (syntax/loc stx (define-struct nm (fs.fld ...) . opts)))] - [dtsi (quasisyntax/loc stx - (dtsi* (vars.vars ...) nm (fs.form ...) - #:maker #,cname - #,@mutable?))]) - (if (eq? (syntax-local-context) 'top-level) - ;; Use `eval` at top-level to avoid an unbound id error - ;; from dtsi trying to look at the d-s bindings. - #'(begin (eval (quote-syntax d-s)) - ;; It is important here that the object under the - ;; eval is a quasiquoted literal in order - ;; for #%top-interaction to get the lexical - ;; information for TR's actual #%top-interaction. - ;; This effectively lets us invoke the type-checker - ;; dynamically. - ;; - ;; The quote-syntax is also important because we want - ;; the `dtsi` to have the lexical information from - ;; this module. This ensures that the `dtsi` macro - ;; is actually bound to its definition above. - (eval `(#%top-interaction . ,(quote-syntax dtsi)))) - #'(begin d-s dtsi))))])) - (lambda (stx) - (syntax-parse stx - [(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...) - opts:struct-options) - (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())] - [prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())]) - (with-syntax ([d-s (ignore (quasisyntax/loc stx - (struct #,@(attribute nm.new-spec) (fs.fld ...) - . opts)))] - [dtsi (quasisyntax/loc stx - (dtsi* (vars.vars ...) - nm.old-spec (fs.form ...) - #,@mutable? - #,@prefab?))]) - ;; see comment above - (if (eq? (syntax-local-context) 'top-level) - #'(begin (eval (quote-syntax d-s)) - (eval `(#%top-interaction . ,(quote-syntax dtsi)))) - #'(begin d-s dtsi))))])))) - - -;Copied from racket/private/define-struct -;FIXME when multiple bindings are supported -(define-for-syntax (self-ctor-transformer orig stx) - (define (transfer-srcloc orig stx) - (datum->syntax orig (syntax-e orig) stx orig)) - (syntax-case stx () - [(self arg ...) (datum->syntax stx - (cons (syntax-property (transfer-srcloc orig #'self) - 'constructor-for - (syntax-local-introduce #'self)) - (syntax-e (syntax (arg ...)))) - stx - stx)] - [_ (transfer-srcloc orig stx)])) - - -(define-for-syntax make-struct-info-self-ctor - (let () - (struct struct-info-self-ctor (id info) - #:property prop:procedure - (lambda (ins stx) - (self-ctor-transformer (struct-info-self-ctor-id ins) stx)) - #:property prop:struct-info (lambda (x) (extract-struct-info (struct-info-self-ctor-info x)))) - struct-info-self-ctor)) - - - -(define-syntaxes (require-typed-struct-legacy - require-typed-struct) - (let () - - (define-splicing-syntax-class (constructor-term legacy struct-name) - (pattern (~seq) #:fail-when legacy #f #:attr name struct-name #:attr extra #f) - (pattern (~seq) #:fail-unless legacy #f #:attr name (format-id struct-name "make-~a" struct-name) #:attr extra #t) - (pattern (~seq #:constructor-name name:id) #:attr extra #f) - (pattern (~seq #:extra-constructor-name name:id) #:attr extra #t)) - - - (define ((rts legacy) stx) - (syntax-parse stx #:literals (:) - [(_ name:opt-parent ([fld : ty] ...) (~var input-maker (constructor-term legacy #'name.nm)) lib) - (with-syntax* ([nm #'name.nm] - [parent #'name.parent] - [hidden (generate-temporary #'name.nm)] - [orig-struct-info (generate-temporary #'nm)] - [spec (if (syntax-e #'name.parent) #'(nm parent) #'nm)] - [num-fields (syntax-length #'(fld ...))] - [(type-des _ pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] - [(mut ...) (stx-map (lambda _ #'#f) #'(sel ...))] - [maker-name #'input-maker.name] - ;maker-name's symbolic form is used in the require form - [id-is-ctor? (or (attribute input-maker.extra) (bound-identifier=? #'maker-name #'nm))] - [internal-maker (generate-temporary #'maker-name)] ;Only used if id-is-ctor? is true - [real-maker (if (syntax-e #'id-is-ctor?) #'internal-maker #'maker-name)] ;The actual identifier bound to the constructor - [extra-maker (and (attribute input-maker.extra) - (not (bound-identifier=? #'make-name #'nm)) - #'maker-name)]) - (define (maybe-add-quote-syntax stx) - (if (and stx (syntax-e stx)) #`(quote-syntax #,stx) stx)) - - (quasisyntax/loc stx - (begin - (require (only-in lib type-des (nm orig-struct-info))) - - (define-for-syntax si - (let () - (define-values (orig-type-des orig-maker orig-pred orig-sels orig-muts orig-parent) - (apply values (extract-struct-info/checked (quote-syntax orig-struct-info)))) - - (define (id-drop sels muts num) - (cond - [(zero? num) (values sels muts)] - [(null? sels) (int-err "id-drop: Too short of list")] - [(pair? sels) - (cond - [(not (car sels)) (values sels muts)] - [else (id-drop (cdr sels) (cdr muts) (sub1 num))])] - [else (int-err "id-drop: Not a list")])) - - (define (struct-info-list new-sels new-muts) - (list (quote-syntax type-des) - (quote-syntax real-maker) - (quote-syntax pred) - (append (list #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(sel ...))))) - new-sels) - (append (list #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(mut ...))))) - new-muts) - orig-parent)) - - (make-struct-info - (lambda () - #,(if (syntax-e #'parent) - (let-values (((parent-type-des parent-maker parent-pred - parent-sel parent-mut grand-parent) - (apply values (extract-struct-info/checked #'parent)))) - #`(struct-info-list - (list #,@(map maybe-add-quote-syntax parent-sel)) - (list #,@(map maybe-add-quote-syntax parent-mut)))) - #`(let-values (((new-sels new-muts) (id-drop orig-sels orig-muts num-fields))) - (struct-info-list new-sels new-muts))))))) - - (define-syntax nm - (if id-is-ctor? - (make-struct-info-self-ctor #'internal-maker si) - si)) - - (dtsi* () spec ([fld : ty] ...) #:maker maker-name #:type-only) - #,(ignore #'(require/contract pred hidden (any/c . c-> . boolean?) lib)) - #,(internal #'(require/typed-internal hidden (Any -> Boolean : nm))) - (require/typed #:internal (maker-name real-maker) nm lib #:struct-maker parent) - - ;This needs to be a different identifier to meet the specifications - ;of struct (the id constructor shouldn't expand to it) - #,(if (syntax-e #'extra-maker) - #'(require/typed #:internal (maker-name extra-maker) nm lib #:struct-maker parent) - #'(begin)) - - (require/typed lib - [sel (nm -> ty)]) ...)))])) - - (values (rts #t) (rts #f)))) (define-syntax (-do stx) (syntax-parse stx #:literals (:) @@ -1062,13 +544,35 @@ the typed racket language. ...))])) (define-for/acc:-variants (for/sum: for/fold: for/sum #f + 0 #%expression) - (for/set: for/fold: for/set #f set-add (set) #%expression) - (for*/set: for*/fold: for*/set #t set-add (set) #%expression) (for*/sum: for*/fold: for*/sum #t + 0 #%expression) (for*/list: for*/fold: for*/list #t (lambda (x y) (cons y x)) null reverse) (for/product: for/fold: for/product #f * 1 #%expression) (for*/product: for*/fold: for*/product #t * 1 #%expression)) +;; originally, we made the mistake of providing these by default in typed/racket/base +;; so now we have this trickery here +;; This trickery is only used for `typed/racket/base`; `typed/racket` just provides the +;; sensible versions directly. +(define-syntaxes (for/set: for*/set:) + (let () + (define ((mk id) stx) + (syntax-case stx () + [(_ . r) + #`(let () + (local-require (only-in (submod typed-racket/base-env/prims for-set) #,id)) + #,(quasisyntax/loc stx (#,id . r)))])) + (values (mk (datum->syntax #'here 'for/set:)) + (mk (datum->syntax #'here 'for*/set:))))) + +(module* for-set #f + (require racket/set) + (provide (rename-out [for/set: for/set] + [for*/set: for*/set]) + for/set: for*/set:) + (define-for/acc:-variants + (for/set: for/fold: for/set #f set-add (set) #%expression) + (for*/set: for*/fold: for*/set #t set-add (set) #%expression))) + (define-for-syntax (define-for/hash:-variant hash-maker) (lambda (stx) (syntax-parse stx diff --git a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index 22e34d21..f00fc3cc 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -19,8 +19,8 @@ (rep object-rep type-rep) (for-syntax racket/base) (for-template racket/base + (submod "internal-forms.rkt" forms) (private class-literals) - (typecheck internal-forms) (utils typed-method-property))) (import tc-expr^) diff --git a/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt b/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt index d18556d6..99583fee 100644 --- a/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt +++ b/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt @@ -1,13 +1,25 @@ #lang racket/base +;; This module defined both Typed Racket-internal forms (such as +;; `define-type-alias-internal`, which is part of the expansion of +;; `define-type`) as well as syntax classes that recognize them and +;; functions that create them. + +;; Since the forms themselves are needed by all Typed Racket programs, +;; they are defined in a `forms` submodule that does _not_ depend on +;; this module itself. That module has a `literal-set` submodule that +;; defines a literal set for use with `syntax/parse`. The further +;; submodule is again to avoid dependency. + (require syntax/parse (for-syntax racket/base racket/syntax syntax/parse syntax/parse/experimental/template) - (for-label racket/base)) + (for-label racket/base) ;; used for identifier comparison only + (for-template racket/base)) (provide - (for-syntax internal) + internal type-alias type-refinement @@ -23,23 +35,31 @@ typed-struct? typed-struct/exec?) -;; Forms -(define-syntax-rule (internal-forms set-name nms ...) - (begin - (provide nms ... set-name) - (define-literal-set set-name (nms ...)) - (define-syntax (nms stx) (raise-syntax-error 'typecheck "Internal typechecker form used out of context" stx)) ...)) +(module forms racket/base + (require (for-syntax racket/base)) + ;; Forms + (define-syntax-rule (internal-forms set-name nms ...) + (begin + (provide nms ...) + (module* literal-set #f + (require syntax/parse) + (provide set-name) + (define-literal-set set-name (nms ...))) + (define-syntax (nms stx) + (raise-syntax-error 'typecheck "Internal typechecker form used out of context" stx)) ...)) + + (internal-forms internal-literals + require/typed-internal + define-type-alias-internal + define-type-internal + define-typed-struct-internal + define-typed-struct/exec-internal + assert-predicate-internal + declare-refinement-internal + :-internal + typecheck-fail-internal)) -(internal-forms internal-literals - require/typed-internal - define-type-alias-internal - define-type-internal - define-typed-struct-internal - define-typed-struct/exec-internal - assert-predicate-internal - declare-refinement-internal - :-internal - typecheck-fail-internal) +(require (submod "." forms) (submod "." forms literal-set)) @@ -130,10 +150,9 @@ (pattern (quote (typecheck-fail-internal stx message:str var)))) ;;; Internal form creation -(begin-for-syntax - (define (internal stx) - (quasisyntax/loc stx - (define-values () - (begin - (quote #,stx) - (#%plain-app values)))))) +(define (internal stx) + (quasisyntax/loc stx + (define-values () + (begin + (quote #,stx) + (#%plain-app values))))) diff --git a/typed-racket-lib/typed-racket/typed-racket.rkt b/typed-racket-lib/typed-racket/typed-racket.rkt index 45bad09e..7806403c 100644 --- a/typed-racket-lib/typed-racket/typed-racket.rkt +++ b/typed-racket-lib/typed-racket/typed-racket.rkt @@ -3,7 +3,13 @@ (require (for-syntax racket/base racket/lazy-require "standard-inits.rkt") - (for-syntax "utils/timing.rkt")) ;; only for timing/debugging + ;; these need to be available to the generated code + "typecheck/renamer.rkt" + (for-syntax (submod "base-env/prims-contract.rkt" self-ctor)) + (for-syntax "utils/struct-extraction.rkt") + (for-syntax "typecheck/renamer.rkt") + ;; only for timing/debugging + (for-syntax "utils/timing.rkt")) (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction]) diff --git a/typed-racket-lib/typed-racket/utils/struct-extraction.rkt b/typed-racket-lib/typed-racket/utils/struct-extraction.rkt new file mode 100644 index 00000000..90f78ffa --- /dev/null +++ b/typed-racket-lib/typed-racket/utils/struct-extraction.rkt @@ -0,0 +1,13 @@ +(module struct-extraction racket/base + (provide extract-struct-info/checked) + (require racket/struct-info) + (define (extract-struct-info/checked id) + (syntax-case id () + [id + (and (identifier? #'id) + (struct-info? (syntax-local-value #'id (lambda () #f)))) + (extract-struct-info (syntax-local-value #'id))] + [_ + (raise-syntax-error + 'require/typed + "expected an identifier bound to a structure type" id)]))) diff --git a/typed-racket-lib/typed/racket.rkt b/typed-racket-lib/typed/racket.rkt index 0c9e7134..0e607a61 100644 --- a/typed-racket-lib/typed/racket.rkt +++ b/typed-racket-lib/typed/racket.rkt @@ -4,9 +4,9 @@ (subtract-in racket typed/racket/base racket/contract typed/racket/class) typed/racket/class - (for-syntax racket/base)) + (for-syntax racket/base)) (provide (all-from-out racket typed/racket/base typed/racket/class) - (for-syntax (all-from-out racket/base)) + (for-syntax (all-from-out racket/base)) class)