Отношение подтипов между типами структур в typed/racket

Математически (чисто функциональная, неизменяемая) struct — это функция, которая сопоставляет имена полей со значениями. Поскольку в typed/racket тип функции, который отображает небольшой набор входных данных, является подмножеством типа функции, который отображает больший набор входных данных, мы можем эмулировать структуры с помощью функций и макроса для небольшого количества синтаксического сахара.

Обратите внимание, что если вы используете более позднюю версию typed/racket, вам, возможно, придется немного изменить синтаксис типа, а именно переместить стрелки → в начало скобок и, возможно, несколько других небольших изменений.

; If it quacks…
(require (for-syntax racket/syntax))
(require (for-syntax syntax/parse))
(define-syntax (duck stx)
  (syntax-parse stx
    [(_ name:id ((field:id (~datum :) type) ...))
     (define/with-syntax make-name (format-id #'name "make-~a" #'name))
     (define/with-syntax (name-field ...) (map (λ (f) (format-id #'name "~a-~a" #'name f)) (syntax-e #'(field ...))))
     #'(begin
         (define-type name
           (case→
            ['field → type] ...)
           #:omit-define-syntaxes)

         (: make-name (type ... → name))
         (define (make-name field ...)
           (λ (field-selector)
             (cond
               [(eq? field-selector 'field) field] ...)))

         ; Remove this line and use (make-mystruct 1 "b" 3)
         ; instead of the shorthand (mystruct 1 "b" 3)
         ; if #:omit-define-syntaxes stops working.
         (define name make-name)

         (begin
           (: name-field (name -> type))
           (define (name-field x)
             (x 'field)))
         ...
         )]))

Использование:

(duck dfoo ([a : Number]))
(duck dbar ([b : String]))
(duck dbaz ([c : String]))
(duck dquux ([a : Number] [d : Number]))
(duck dfloz ([a : Number] [c : Number]))
(duck dst ([a : Number] [b : String] [c : Number]))

(define upcast-foo ((λ: ([x : dfoo]) x) (dst 1 "b" 3)))
(define upcast-bar ((λ: ([x : dbar]) x) (dst 1 "b" 3)))

; This one fails because dbaz has c : String instead of c : Number
; (define result-baz ((λ: ([x : dbaz]) x) (dst 1 "b" 3)))

; This one is not even close (wrong field name)
; (define result-quux ((λ: ([x : dquux]) x) (dst 1 "b" 3)))
(define upcast-floz ((λ: ([x : dfloz]) x) (dst 1 "b" 3)))

(dfoo-a upcast-foo) ; 1
(dbar-b upcast-bar) ; "b"
(dfloz-a upcast-floz) ; 1
(dfloz-c upcast-floz) ; 3

; Fails with error: "Type Checker: Expected dfoo, but got dbar in: upcast-bar"
; (dfoo-a upcast-bar)

Макрос duck генерирует этот код для dst:

(define-type dst
 (case->
  ['a -> Number]
  ['b -> String]
  ['c -> Number])
  #:omit-define-syntaxes)

(: make-dst (Number String Number -> dst))
(define (make-dst a b c)
  (λ (field-name)
    (cond
      [(eq? field-name 'a) a]
      [(eq? field-name 'b) b]
      [(eq? field-name 'c) c])))

(define dst make-dst)

(begin
  (: dst-a (dst -> Number))
  (define (dst-a x)
    (x 'a)))
(begin
  (: dst-b (dst -> String))
  (define (dst-b x)
    (x 'b)))
(begin
  (: dst-c (dst -> Number))
  (define (dst-c x)
    (x 'c)))

Эта функция уже реализован для классов в typed/racket (в v6.2.0.2 и, возможно, в v6.1.1 тоже):

#lang typed/racket

(require (for-syntax syntax/parse))
(require (for-syntax racket/syntax))

(define-syntax (duck stx)
  (syntax-parse stx
    [(_ (field type) ...)
     (define/with-syntax (the-field ...) (map (λ (f) (format-id f "the-~a" f)) (syntax-e #'(field ...))))
     (define/with-syntax (get-field ...) (map (λ (f) (format-id f "get-~a" f)) (syntax-e #'(field ...))))
     #'(class object%
         (super-new)

         (init [field : type] ...)

         (define the-field : type
           field) ...

         (define/public (get-field) : type
           the-field) ...
         )]))

Использование:

(: foo (Object (get-x (→ Real)) (get-y (→ String))))
(define foo (new (duck (x Real)
                       (z Number)
                       (y String))
                 [x 42]
                 [z 123]
                 [y "y"]))
(send foo get-x)
(send foo get-y)
; (send foo get-z) ;; Does not typecheck, as expected.

Однако у него есть недостаток, заключающийся в том, что нельзя объявить неизменяемые классы, и поэтому вхождение типа не работает в полях класса, т.е. следующее не работает:

(if (zero? (send foo get-x))
  (ann (send foo get-x) Zero))