[Feature Request] Tag Contract and Tag Type

Questions & Answers
3

Before posting my thought, I didn’t know much about Racket’s contract. After that, I studied the impersonator from document and tried to write a simple implementation:
(I didn't find the chaperone contract for mlist, so I replaced the original mlist example with box)

main.rkt:

#lang racket/base

(require racket/contract racket/match)
(provide tag-contract tag-contract? tag-contract-recover)


(define-values (prop:tags prop:tags? prop:tags-get)
  (make-impersonator-property 'prop:tags))

(define/contract (tag-contract? arg)
  (-> any/c boolean?)
  (and (contract? arg)
       (match (contract-name arg)
         [`((tag-contract ,_) . ,(? symbol?)) #t]
         [_ #f])))

(define/contract (tag-contract base-contract)
  (-> chaperone-contract? tag-contract?)

  (define t (gensym))
  (make-contract #:name `((tag-contract ,(contract-name base-contract)) . ,t)
                 #:projection
                 (λ (b)
                   (define base-proj (contract-projection base-contract))
                   (define base (base-proj (blame-swap b)))
                   (λ (arg)
                     (match (base arg)
                       #;[(? procedure? p)]
                       #;[(? struct? s)]
                       #;[(? vector? v)]
                       [(? box? b)
                        (chaperone-box b
                                       (λ (b o) o)
                                       (λ (b i) i)
                                       prop:tags
                                       (if (prop:tags? b)
                                           (hash-set (prop:tags-get b) t b)
                                           (hasheq t b)))]
                       #;[(? hash? h)]
                       #;[(? channel? ch)]
                       #;[(? continuation-mark-key? cmk)])))))

(define/contract (tag-contract-recover tc)
  (-> tag-contract? (-> any/c any/c))

  (match-define `((tag-contract ,_) . ,t) (contract-name tc))
  (λ (arg)
    (and (prop:tags? arg)
         (hash-has-key? (prop:tags-get arg) t)
         (hash-ref (prop:tags-get arg) t))))

test-box.rkt:

#lang racket

(require "main.rkt")


(define box-number/t  (tag-contract (box/c number?)))
(define box-boolean/t (tag-contract (box/c boolean?)))

(define box-number/r  (tag-contract-recover box-number/t))
(define box-boolean/r (tag-contract-recover box-boolean/t))

(define T?
  (first-or/c symbol? string?
              (and/c (box/c number?  #:flat? #t) box-number/t)
              (and/c (box/c boolean? #:flat? #t) box-boolean/t)))


(define/contract (g arg)
  (-> (box/c none/c any/c) number?)

  (cond [(box-boolean/r arg)
         => (λ (arg)
              (set-box! arg (not (unbox arg)))
              (if (unbox arg) 1 -1))]
        [(box-number/r arg)
         => (λ (arg)
              (set-box! arg (- (unbox arg)))
              (unbox arg))]
        [else -123]))

(define/contract (f arg)
  (-> T? number?)

  (cond [(string? arg) (string-length arg)]
        [(symbol? arg) (string-length (symbol->string arg))]
        [else (g arg)]))


(f (box 10))    ; -10
(f (box #t))    ; -1
(f (box #f))    ;  1

This is the code I imagined in Typed Racket:

#lang typed/racket


(define-type Box-Number  (Tag (Boxof Number)))
(define-type Box-Boolean (Tag (Boxof Boolean)))

(define-recover box-number/r  Box-Number)
(define-recover box-boolean/r Box-Boolean)

(define-type T (U Symbol String Box-Number Box-Boolean))


(: g [-> (Boxof Nothing Any) Number])
(define (g arg)
  (cond [(box-boolean/r arg)
         => (λ (arg)
              (set-box! arg (not (unbox arg)))
              (if (unbox arg) 1 -1))]
        [(box-number/r arg)
         => (λ (arg)
              (set-box! arg (- (unbox arg)))
              (unbox arg))]
        [else -123]))

(: f [-> T Number])
(define (f arg)
  (cond [(string? arg) (string-length arg)]
        [(symbol? arg) (string-length (symbol->string arg))]
        [else (g arg)]))


(f (box 10))    ; -10
(f (box #t))    ; -1
(f (box #f))    ;  1