diff --git a/racket/typed/examples/require-struct/omit-accs/lib.rkt b/racket/typed/examples/require-struct/omit-accs/lib.rkt new file mode 100644 index 0000000..5900a63 --- /dev/null +++ b/racket/typed/examples/require-struct/omit-accs/lib.rkt @@ -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) diff --git a/racket/typed/examples/require-struct/omit-accs/require-omit-accs.rkt b/racket/typed/examples/require-struct/omit-accs/require-omit-accs.rkt new file mode 100644 index 0000000..399901c --- /dev/null +++ b/racket/typed/examples/require-struct/omit-accs/require-omit-accs.rkt @@ -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)]) diff --git a/racket/typed/examples/require:typed/opaque/client-arity.rkt b/racket/typed/examples/require:typed/opaque/client-arity.rkt new file mode 100644 index 0000000..abb0c26 --- /dev/null +++ b/racket/typed/examples/require:typed/opaque/client-arity.rkt @@ -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) diff --git a/racket/typed/examples/require:typed/opaque/client.rkt b/racket/typed/examples/require:typed/opaque/client.rkt new file mode 100644 index 0000000..2093882 --- /dev/null +++ b/racket/typed/examples/require:typed/opaque/client.rkt @@ -0,0 +1,8 @@ +#lang typed/syndicate + +(require/typed "lib.rkt" + [#:opaque Vec] + [ones : Vec] + [vec+ : (→fn Vec Vec Vec)]) + +(vec+ ones ones) diff --git a/racket/typed/examples/require:typed/opaque/lib.rkt b/racket/typed/examples/require:typed/opaque/lib.rkt new file mode 100644 index 0000000..218f0ce --- /dev/null +++ b/racket/typed/examples/require:typed/opaque/lib.rkt @@ -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)))) diff --git a/racket/typed/syndicate/core-types.rkt b/racket/typed/syndicate/core-types.rkt index 0d97e7b..d492b51 100644 --- a/racket/typed/syndicate/core-types.rkt +++ b/racket/typed/syndicate/core-types.rkt @@ -730,7 +730,7 @@ ;; TODO: this implementation shares a lot with that of define-constructor (define-syntax (require-struct 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] [MakeTypeCons (format-id #'TypeCons "make-~a" #'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)) (unless (boolean? sup) (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-for-syntax (TypeConsExtraInfo stx) @@ -767,10 +766,14 @@ (define-syntax GetTypeParams (mk-type-params-fetcher #'TypeCons)) (define-syntax Cons- (mk-constructor-type-rule arity #'orig-struct-info #'TypeCons)) (define-syntax ucons - (user-ctor #'Cons- #'orig-struct-info 'type-tag #'TypeCons (cleanup-accs #'ucons accs/rev) #;accs)) - (define-syntax mk-struct-accs - (define-struct-accs accs/rev #'TypeCons #'lib)) - (mk-struct-accs ucons))))])) + (user-ctor #'Cons- #'orig-struct-info 'type-tag #'TypeCons (cleanup-accs #'ucons accs/rev))) + #,(unless (attribute omit-accs) + (quasisyntax/loc stx + (begin- + (define-syntax mk-struct-accs + (define-struct-accs accs/rev #'TypeCons #'lib)) + (mk-struct-accs ucons)))) + )))])) (begin-for-syntax (define-syntax ~constructor-extra-info @@ -838,21 +841,32 @@ ;; 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 ;; TODO: this is where contracts would need to go (define-syntax (require/typed stx) (syntax-parse stx #:datum-literals (:) - [(_ lib [name:id : ty:type] ...) + [(_ lib + (~alt [name:id : ty] + opaque-clause:opaque-require-clause) + ...) #:with (name- ...) (format-ids "~a-" #'(name ...)) - #:with (serialized-ty ...) (for/list ([t (in-syntax #'(ty.norm ...))]) - (serialize-syntax t)) (syntax/loc stx (begin- + opaque-clause.type-definition ... (require (only-in lib [name name-] ...)) (define-syntax name (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))) ...))]))