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

Correctly require/typed structs with parents. Closes PR11509.

Browse Source 
original commit: 805e1fb309487ba8903b84e27b575fea485b8748
This commit is contained in:
Eric Dobson 2011-07-02 13:18:05 -04:00 committed by Vincent St-Amour
parent ad93c3fbfc
commit 9e1e05efad
2 changed files with 62 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/tests/typed-scheme/succeed/pr11509.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang racket/load
(module server racket
(define-struct pt [x y])
(define-struct (cpt pt) [color])
(provide (all-defined-out)))
(module client racket
(require 'server)
(match (cpt 100 200 'red)
[(cpt x y c) (list x y c)]))
(module tclient typed/racket
(require-typed-struct
pt ([x : Integer] [y : Integer])
'server)
(require-typed-struct
(cpt pt) ([color : Symbol])
'server)
(match (cpt 100 200 'red)
[(cpt x y c) (list x y c)]))
(require 'client)
(require 'tclient)

45
collects/typed-scheme/base-env/prims.rkt
View File

@ -439,6 +439,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
(pattern (~seq #:constructor-name name:id) #:attr extra #f)
(pattern (~seq #:extra-constructor-name name:id) #:attr extra #t))
(define (maybe-add-quote-syntax stx)
(if (and stx (syntax-e stx)) #`(quote-syntax #,stx) stx))
(define ((rts legacy) stx)
(syntax-parse stx #:literals (:)
@ -446,8 +448,10 @@ This file defines two sorts of primitives. All of them are provided into any mod
(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)]
[(struct-info _ pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[num-fields (length (syntax->list #'(fld ...)))]
[(type-des _ pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
[maker-name #'input-maker.name]
;maker-name's symbolic form is used in the require form
@ -459,17 +463,42 @@ This file defines two sorts of primitives. All of them are provided into any mod
#'maker-name)])
(quasisyntax/loc stx
(begin
(require (only-in lib struct-info))
(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 (syntax-local-value (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"))))
(make-struct-info
(lambda ()
(list #'struct-info
#'real-maker
#'pred
(reverse (list #'sel ...))
(list mut ...)
#f))))
#,(if (syntax-e #'parent)
(let-values (((parent-type-des parent-maker parent-pred
parent-sel parent-mut grand-parent)
(apply values (extract-struct-info (syntax-local-value #'parent)))))
#`(list (quote-syntax type-des)
(quote-syntax real-maker)
(quote-syntax pred)
(list #,@(map maybe-add-quote-syntax (append (reverse (syntax->list #'(sel ...))) parent-sel)))
(list #,@(map maybe-add-quote-syntax (append (reverse (syntax->list #'(mut ...))) parent-mut)))
(quote-syntax parent)))
#`(let-values (((new-sels new-muts) (id-drop orig-sels orig-muts num-fields)))
(list (quote-syntax type-des)
(quote-syntax real-maker)
(quote-syntax pred)
(list* #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(sel ...)))) new-sels)
(list* #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(mut ...)))) new-muts)
orig-parent)))))))
(define-syntax nm
(if id-is-ctor?