49 lines
1.4 KiB
Racket
49 lines
1.4 KiB
Racket
#lang racket/base
|
|
|
|
(provide (prefix-out mirror: (struct-out record))
|
|
(rename-out [record-expander record]
|
|
[record?* record?]
|
|
[record-label* record-label]
|
|
[record-fields* record-fields]))
|
|
|
|
(require racket/match)
|
|
(require "struct.rkt")
|
|
|
|
(struct record (label fields) #:transparent)
|
|
|
|
(define (build-record label fields)
|
|
(with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))]
|
|
(apply make-prefab-struct label fields)))
|
|
|
|
(define (unrecord r)
|
|
(match r
|
|
[(record label fields) (values #t label fields)]
|
|
[(? non-object-struct?)
|
|
(define key (prefab-struct-key r))
|
|
(when (not key) (error 'preserves "Cannot process non-prefab struct ~v" r))
|
|
(values #t key (cdr (vector->list (struct->vector r))))]
|
|
[_ (values #f #f #f)]))
|
|
|
|
(define-match-expander record-expander
|
|
(syntax-rules () [(_ lpat fpat) (app unrecord #t lpat fpat)])
|
|
(syntax-rules () [(_ lval fval) (build-record lval fval)]))
|
|
|
|
(define (record?* r)
|
|
(match r
|
|
[(record-expander _ _) #t]
|
|
[_ #f]))
|
|
|
|
(define (record-label* r)
|
|
(match-define (record-expander l _) r)
|
|
l)
|
|
|
|
(define (record-fields* r)
|
|
(match-define (record-expander _ f) r)
|
|
f)
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
(check-true (record?* (build-record "label" (list 123 234))))
|
|
(check-true (record?* (build-record 'label (list 123 234))))
|
|
(check-false (record?* "string")))
|