Browse Source

Allow importing structs without accessors and opaque external types

main
Sam Caldwell 9 months ago
parent
commit
3f6a5573e4
  1. 12
      racket/typed/examples/require-struct/omit-accs/lib.rkt
  2. 18
      racket/typed/examples/require-struct/omit-accs/require-omit-accs.rkt
  3. 8
      racket/typed/examples/require:typed/opaque/client-arity.rkt
  4. 8
      racket/typed/examples/require:typed/opaque/client.rkt
  5. 13
      racket/typed/examples/require:typed/opaque/lib.rkt
  6. 34
      racket/typed/syndicate/core-types.rkt

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

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

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

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

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

34
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)))
...))]))

Loading…
Cancel
Save