<commit_before>#lang racket/base
(provide
  define-type
  define-variant-type
  )
(require
  racket/struct
  racket/vector
  )

(struct record (tag payload)
        #:methods gen:custom-write
        ((define write-proc
           (make-constructor-style-printer
             (lambda (d) (record-tag d))
             (lambda (d) (vector->list (record-payload d)))))))

(define-syntax define-type
  (syntax-rules ()
    ((_ (name singleton-name) name?)
     (define-type/singleton name singleton-name name?))
    ((_ (name construct) name? f* ...)
     (define-type/multi-field name construct name? f* ...))
    ((_ name name?) (define-type/singleton name name name?))
    ((_ name name? f* ...) (define-type/multi-field name name name? f* ...))))
(define-syntax define-type/singleton
  (syntax-rules ()
    ((_ tag singleton-name name?)
     (begin (define singleton-name (record 'tag '#()))
            (define (name? datum) (eq? tag datum))))))
(define-syntax define-type/multi-field
  (syntax-rules ()
    ((_ tag construct name? f* ...)
     (begin (define (name? datum)
              (and (record? datum) (eq? 'tag (record-tag datum))))
            (define-type-etc tag construct 0 (f* ...) ())))))
(define-syntax define-type-etc
  (syntax-rules ()
    ((_ tag construct _ () (field* ...))
     (define (construct field* ...) (record 'tag (vector field* ...))))
    ((_ tag construct index ((get set) f* ...) field*)
     (begin (define-type-etc tag construct index (get f* ...) field*)
            (define (set datum value)
              (let ((new (vector-copy (record-payload datum))))
                (vector-set! new index value)
                (record 'tag new)))))
    ((_ tag construct index (get f* ...) (field* ...))
     (begin (define-type-etc tag construct (+ 1 index) (f* ...) (field* ... get))
            (define (get datum) (vector-ref (record-payload datum) index))))))

(define-syntax define-variant-type
  (syntax-rules ()
    ((_ vp? v* ...) (define-variant-type-etc vp? (v* ...) ()))))
(define-syntax define-variant-type-etc
  (syntax-rules ()
    ((_ vp? () (p?* ...))
     (define (vp? d) (ormap (lambda (p?) (p? d)) (list p?* ...))))
    ((_ vp? ((vname v? field* ...) v* ...) (p?* ...))
     (begin (define-type vname v? field* ...)
            (define-variant-type-etc vp? (v* ...) (p?* ... v?))))))<commit_msg>Define types with unique tags and optional repr<commit_after>#lang racket/base
(provide
  define-type
  define-variant-type
  )
(require
  racket/struct
  racket/vector
  )

(define tag=>details (hash))
(define tag-current -1)
(define (tag-fresh! name repr)
  (set! tag-current (+ 1 tag-current))
  (set! tag=>details (hash-set tag=>details tag-current (cons name repr)))
  tag-current)
(define (tag->details tag) (hash-ref tag=>details tag))

(struct record (tag payload)
        #:methods gen:custom-write
        ((define write-proc
           (make-constructor-style-printer
             (lambda (d) (car (tag->details (record-tag d))))
             (lambda (d)
               (define repr (cdr (tag->details (record-tag d))))
               (if repr (repr d) (vector->list (record-payload d))))))))

(define-syntax define-type
  (syntax-rules ()
    ((_ (name singleton-name repr) name?)
     (define-type/singleton name singleton-name repr name?))
    ((_ (name construct repr) name? f* ...)
     (define-type/multi-field name construct repr name? f* ...))
    ((_ (name c) name? f* ...) (define-type (name c #f) name? f* ...))
    ((_ name name? f* ...) (define-type (name name #f) name? f* ...))))
(define-syntax define-type/singleton
  (syntax-rules ()
    ((_ name singleton-name repr name?)
     (begin (define tag (tag-fresh! 'name repr))
            (define singleton-name (record tag '#()))
            (define (name? datum) (eq? tag datum))))))
(define-syntax define-type/multi-field
  (syntax-rules ()
    ((_ name construct repr name? f* ...)
     (begin (define tag (tag-fresh! 'name repr))
            (define (name? datum)
              (and (record? datum) (eq? tag (record-tag datum))))
            (define-type-etc tag construct 0 (f* ...) ())))))
(define-syntax define-type-etc
  (syntax-rules ()
    ((_ tag construct _ () (field* ...))
     (define (construct field* ...) (record tag (vector field* ...))))
    ((_ tag construct index ((get set) f* ...) field*)
     (begin (define-type-etc tag construct index (get f* ...) field*)
            (define (set datum value)
              (let ((new (vector-copy (record-payload datum))))
                (vector-set! new index value)
                (record tag new)))))
    ((_ tag construct index (get f* ...) (field* ...))
     (begin (define-type-etc tag construct (+ 1 index) (f* ...) (field* ... get))
            (define (get datum) (vector-ref (record-payload datum) index))))))

(define-syntax define-variant-type
  (syntax-rules ()
    ((_ vp? v* ...) (define-variant-type-etc vp? (v* ...) ()))))
(define-syntax define-variant-type-etc
  (syntax-rules ()
    ((_ vp? () (p?* ...))
     (define (vp? d) (ormap (lambda (p?) (p? d)) (list p?* ...))))
    ((_ vp? ((vname v? field* ...) v* ...) (p?* ...))
     (begin (define-type vname v? field* ...)
            (define-variant-type-etc vp? (v* ...) (p?* ... v?))))))
{'fraction_non_alphanumeric': 0.20091585575271895, 'fraction_numerical': 0.0011448196908986834, 'mean_word_length': 2.3994811932555122, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 12, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '179591', 'n_tokens_mistral': 1768, 'n_tokens_neox': 1672, 'n_words': 476}