Allow importing structs without accessors and opaque external types
This commit is contained in:
parent
98c58d3e6f
commit
3f6a5573e4
|
@ -0,0 +1,12 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(struct egg (size day) #:transparent)
|
||||||
|
|
||||||
|
(provide (except-out (struct-out egg)
|
||||||
|
egg-size
|
||||||
|
egg-day))
|
||||||
|
|
||||||
|
|
||||||
|
(struct chicken (eggs) #:transparent)
|
||||||
|
|
||||||
|
(provide chicken)
|
|
@ -0,0 +1,18 @@
|
||||||
|
#lang typed/syndicate/roles
|
||||||
|
|
||||||
|
(require-struct egg #:as Egg #:from "lib.rkt" #:omit-accs)
|
||||||
|
|
||||||
|
(define e (egg 5 "Sun"))
|
||||||
|
|
||||||
|
(match e
|
||||||
|
[(egg $sz $d)
|
||||||
|
(displayln sz)
|
||||||
|
(displayln d)])
|
||||||
|
|
||||||
|
(require-struct chicken #:as Chicken #:from "lib.rkt" #:omit-accs)
|
||||||
|
|
||||||
|
(define c (chicken (list e e e)))
|
||||||
|
|
||||||
|
(match c
|
||||||
|
[(chicken $eggs)
|
||||||
|
(displayln eggs)])
|
|
@ -0,0 +1,8 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require/typed "lib.rkt"
|
||||||
|
[#:opaque Vec #:arity = 3]
|
||||||
|
[ones : (Vec Int Int Int)]
|
||||||
|
[vec+ : (→fn (Vec Int Int Int) (Vec Int Int Int) (Vec Int Int Int))])
|
||||||
|
|
||||||
|
(vec+ ones ones)
|
|
@ -0,0 +1,8 @@
|
||||||
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
(require/typed "lib.rkt"
|
||||||
|
[#:opaque Vec]
|
||||||
|
[ones : Vec]
|
||||||
|
[vec+ : (→fn Vec Vec Vec)])
|
||||||
|
|
||||||
|
(vec+ ones ones)
|
|
@ -0,0 +1,13 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(provide ones
|
||||||
|
vec+)
|
||||||
|
|
||||||
|
(struct vec (x y z) #:transparent)
|
||||||
|
|
||||||
|
(define ones (vec 1 1 1))
|
||||||
|
|
||||||
|
(define (vec+ v1 v2)
|
||||||
|
(vec (+ (vec-x v1) (vec-x v2))
|
||||||
|
(+ (vec-y v1) (vec-y v2))
|
||||||
|
(+ (vec-z v1) (vec-z v2))))
|
|
@ -730,7 +730,7 @@
|
||||||
;; TODO: this implementation shares a lot with that of define-constructor
|
;; TODO: this implementation shares a lot with that of define-constructor
|
||||||
(define-syntax (require-struct stx)
|
(define-syntax (require-struct stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ ucons:id #:as ty-cons:id #:from lib)
|
[(_ ucons:id #:as ty-cons:id #:from lib (~optional (~and omit-accs #:omit-accs)))
|
||||||
(with-syntax* ([TypeCons #'ty-cons]
|
(with-syntax* ([TypeCons #'ty-cons]
|
||||||
[MakeTypeCons (format-id #'TypeCons "make-~a" #'TypeCons)]
|
[MakeTypeCons (format-id #'TypeCons "make-~a" #'TypeCons)]
|
||||||
[GetTypeParams (format-id #'TypeCons "get-~a-type-params" #'TypeCons)]
|
[GetTypeParams (format-id #'TypeCons "get-~a-type-params" #'TypeCons)]
|
||||||
|
@ -751,7 +751,6 @@
|
||||||
(raise-syntax-error #f "number of slots must be exact" #'#,stx #'ucons))
|
(raise-syntax-error #f "number of slots must be exact" #'#,stx #'ucons))
|
||||||
(unless (boolean? sup)
|
(unless (boolean? sup)
|
||||||
(raise-syntax-error #f "structs with super-type not supported" #'#,stx #'ucons))
|
(raise-syntax-error #f "structs with super-type not supported" #'#,stx #'ucons))
|
||||||
(define accs (cleanup-accs #'ucons accs/rev))
|
|
||||||
(define arity (length accs/rev))
|
(define arity (length accs/rev))
|
||||||
)
|
)
|
||||||
(define-for-syntax (TypeConsExtraInfo stx)
|
(define-for-syntax (TypeConsExtraInfo stx)
|
||||||
|
@ -767,10 +766,14 @@
|
||||||
(define-syntax GetTypeParams (mk-type-params-fetcher #'TypeCons))
|
(define-syntax GetTypeParams (mk-type-params-fetcher #'TypeCons))
|
||||||
(define-syntax Cons- (mk-constructor-type-rule arity #'orig-struct-info #'TypeCons))
|
(define-syntax Cons- (mk-constructor-type-rule arity #'orig-struct-info #'TypeCons))
|
||||||
(define-syntax ucons
|
(define-syntax ucons
|
||||||
(user-ctor #'Cons- #'orig-struct-info 'type-tag #'TypeCons (cleanup-accs #'ucons accs/rev) #;accs))
|
(user-ctor #'Cons- #'orig-struct-info 'type-tag #'TypeCons (cleanup-accs #'ucons accs/rev)))
|
||||||
(define-syntax mk-struct-accs
|
#,(unless (attribute omit-accs)
|
||||||
(define-struct-accs accs/rev #'TypeCons #'lib))
|
(quasisyntax/loc stx
|
||||||
(mk-struct-accs ucons))))]))
|
(begin-
|
||||||
|
(define-syntax mk-struct-accs
|
||||||
|
(define-struct-accs accs/rev #'TypeCons #'lib))
|
||||||
|
(mk-struct-accs ucons))))
|
||||||
|
)))]))
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define-syntax ~constructor-extra-info
|
(define-syntax ~constructor-extra-info
|
||||||
|
@ -838,21 +841,32 @@
|
||||||
;; Require & Provide
|
;; Require & Provide
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(define-syntax-class opaque-require-clause
|
||||||
|
#:datum-literals (= > >=)
|
||||||
|
#:attributes (type-definition)
|
||||||
|
(pattern [#:opaque ty-name:id]
|
||||||
|
#:attr type-definition #'(define-base-type ty-name))
|
||||||
|
(pattern [#:opaque ty-name:id #:arity (~and op (~or* = > >=)) arity:nat]
|
||||||
|
#:attr type-definition #'(define-product-type ty-name #:arity op arity))))
|
||||||
|
|
||||||
;; Import and ascribe a type from an untyped module
|
;; Import and ascribe a type from an untyped module
|
||||||
;; TODO: this is where contracts would need to go
|
;; TODO: this is where contracts would need to go
|
||||||
(define-syntax (require/typed stx)
|
(define-syntax (require/typed stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
#:datum-literals (:)
|
#:datum-literals (:)
|
||||||
[(_ lib [name:id : ty:type] ...)
|
[(_ lib
|
||||||
|
(~alt [name:id : ty]
|
||||||
|
opaque-clause:opaque-require-clause)
|
||||||
|
...)
|
||||||
#:with (name- ...) (format-ids "~a-" #'(name ...))
|
#:with (name- ...) (format-ids "~a-" #'(name ...))
|
||||||
#:with (serialized-ty ...) (for/list ([t (in-syntax #'(ty.norm ...))])
|
|
||||||
(serialize-syntax t))
|
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(begin-
|
(begin-
|
||||||
|
opaque-clause.type-definition ...
|
||||||
(require (only-in lib [name name-] ...))
|
(require (only-in lib [name name-] ...))
|
||||||
(define-syntax name
|
(define-syntax name
|
||||||
(make-variable-like-transformer
|
(make-variable-like-transformer
|
||||||
(add-orig (assign-type #'name- (deserialize-syntax #'serialized-ty)
|
(add-orig (assign-type #'name- (deserialize-syntax (serialize-syntax (type-eval #'ty)))
|
||||||
#:wrap? #f) #'name)))
|
#:wrap? #f) #'name)))
|
||||||
...))]))
|
...))]))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue