72 lines
2.8 KiB
Racket
72 lines
2.8 KiB
Racket
#lang racket
|
|
|
|
(module untyped racket
|
|
(provide (struct-out untyped-object))
|
|
|
|
(define-struct untyped-object ()
|
|
#:transparent
|
|
;#:property prop:procedure (λ (self . rest)
|
|
; (apply (untyped-object-proc self) rest))
|
|
#:methods gen:custom-write
|
|
[(define write-proc (λ (self port mode)
|
|
(let* ([f (vector-ref (struct->vector self) 1)]
|
|
[write-proc (f 'write-proc)])
|
|
(write-proc port mode))))]
|
|
#:methods gen:equal+hash
|
|
[(define equal-proc (λ (x y recursive-equal?)
|
|
(let* ([f (vector-ref (struct->vector x) 1)]
|
|
[equal-proc (f 'equal-proc)])
|
|
(f y recursive-equal?))))
|
|
(define hash-proc (λ (x recursive-equal-hash-code?)
|
|
(let* ([f (vector-ref (struct->vector x) 1)]
|
|
[hash-proc (f 'hash-proc)])
|
|
(hash-proc recursive-equal-hash-code?))))
|
|
(define hash2-proc (λ (x recursive-equal-secondary-hash-code?)
|
|
(let* ([f (vector-ref (struct->vector x) 1)]
|
|
[hash2-proc (f 'hash2-proc)])
|
|
(hash2-proc
|
|
recursive-equal-secondary-hash-code?))))]))
|
|
|
|
|
|
(module typed typed/racket
|
|
(require/typed (submod ".." untyped)
|
|
[#:struct untyped-object ()])
|
|
|
|
(define-type Field-Present (Vector Any))
|
|
|
|
(: field-present (→ Any Field-Present))
|
|
(define (field-present x) (vector x))
|
|
|
|
(: field-present-get-value (→ Field-Present Any))
|
|
(define (field-present-get-value fp) (vector-ref fp 0))
|
|
|
|
(struct (T) Equatable untyped-object
|
|
([f : (case→ [→ 'value T]
|
|
;; Above: Sadly, we can't extend a case→ described by T,
|
|
;; so we have to chain two calls to access any field.
|
|
|
|
;; TODO: we could just directly accept the other parameters
|
|
[→ 'write-proc (→ Output-Port (U #t #f 0 1)
|
|
Any)]
|
|
[→ 'equal-proc (→ (U Equatable Any) (→ Any Any Boolean)
|
|
Boolean)]
|
|
[→ 'hash-proc (→ (→ Any Fixnum)
|
|
Fixnum)]
|
|
[→ 'hash2-proc (→ (→ Any Fixnum)
|
|
Fixnum)]
|
|
[→ 'reflect (→ (U Index Symbol)
|
|
(U Field-Present #f))])])
|
|
#:transparent)
|
|
|
|
(: Equatable-value (∀ (T) (→ (Equatable T) T)))
|
|
(define (Equatable-value e) ((Equatable-f e) 'value))
|
|
|
|
(provide (struct-out Equatable)
|
|
Equatable-value
|
|
Field-Present
|
|
field-present
|
|
field-present-get-value))
|
|
|
|
(require 'typed)
|
|
(provide (all-from-out 'typed))
|