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

Split prims.rkt to reduce dependencies.

Browse Source 
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`.
This commit is contained in:
Sam Tobin-Hochstadt 2015-03-18 11:31:11 -04:00
parent 333a8b9bd7
commit 4709536653
12 changed files with 825 additions and 594 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
typed-racket-lib/typed-racket/base-env/ann-inst.rkt Normal file
View File

@ -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)))]))

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

@ -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]

2
typed-racket-lib/typed-racket/base-env/class-prims.rkt
View File

@ -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"

2
typed-racket-lib/typed-racket/base-env/colon.rkt
View File

@ -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 :)

438
typed-racket-lib/typed-racket/base-env/prims-contract.rkt Normal file
View File

@ -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))))

211
typed-racket-lib/typed-racket/base-env/prims-struct.rkt Normal file
View File

@ -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))))]))

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

@ -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

2
typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

@ -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^)

69
typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
View File

@ -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)))))

8
typed-racket-lib/typed-racket/typed-racket.rkt
View File

@ -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])

13
typed-racket-lib/typed-racket/utils/struct-extraction.rkt Normal file
View File

@ -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)])))

4
typed-racket-lib/typed/racket.rkt
View File

@ -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)