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

Make TR provided struc-infos act like constructors. Closes PR11578.

Browse Source 
Closes PR11866.

original commit: d0cfebd5b464076bbfa136861ffbaaae2d400620
This commit is contained in:
Eric Dobson 2011-06-29 17:02:29 -04:00 committed by Vincent St-Amour
parent 65638b0d8b
commit c8c1cdc655
4 changed files with 55 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/tests/typed-scheme/succeed/pr11578.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang racket/load
(module a typed/racket/base
(provide foo)
(struct: foo ()))
(module b racket/base
(require 'a)
(foo))
(require 'b)

10
collects/tests/typed-scheme/succeed/pr11866.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang racket/load
(module a typed/racket
(struct: S ((x : Integer)) #:transparent)
(provide (all-defined-out)))
(module b typed/racket/no-check
(require 'a)
(S 5))
(require 'b)

6
collects/typed-scheme/typecheck/provide-handling.rkt
View File

@ -51,6 +51,7 @@
(define (mk-untyped-syntax b defn-id internal-id)
(match b
[(def-struct-stx-binding _ (? struct-info? si))
(define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same)
(match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)])
(let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e)
(mk e)
@ -63,7 +64,10 @@
#`(begin
#,@defns
(define-syntax #,defn-id
(list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))]
(let ((info (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*)))
#,(if type-is-constructor?
#'(make-struct-info-self-ctor constr* info)
#'info)))))))]
[_
#`(define-syntax #,defn-id
(lambda (stx)

29
collects/typed-scheme/utils/utils.rkt
View File

@ -8,7 +8,7 @@ at least theoretically.
(require (for-syntax racket/base syntax/parse racket/string)
racket/contract racket/require-syntax
racket/provide-syntax racket/unit (prefix-in d: unstable/debug)
racket/pretty mzlib/pconvert syntax/parse)
racket/struct-info racket/pretty mzlib/pconvert syntax/parse)
;; to move to unstable
(provide reverse-begin list-update list-set debugf debugging? dprintf)
@ -237,3 +237,30 @@ at least theoretically.
(define debugging? (make-parameter #f))
(define-syntax-rule (debugf f . args) (if (debugging?) (d:debugf f . args) (f . args)))
(define (dprintf . args) (when (debugging?) (apply d:dprintf args)))
(provide make-struct-info-self-ctor)
;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 (lambda (x) (extract-struct-info (struct-info-self-ctor-info x))))
struct-info-self-ctor))