89 lines
2.7 KiB
Racket
89 lines
2.7 KiB
Racket
#lang racket
|
|
|
|
(require syntax/parse/experimental/template
|
|
syntax/parse
|
|
(for-syntax racket/syntax))
|
|
|
|
(provide meta-struct?
|
|
(struct-out meta-struct-info)
|
|
get-meta-struct-info
|
|
;; More provided by `shorthand` in the code below
|
|
meta-struct-subtype?
|
|
struct-predicate
|
|
struct-constructor
|
|
struct-accessor)
|
|
|
|
(module info racket
|
|
(require racket/struct-info)
|
|
|
|
(provide meta-struct?
|
|
(struct-out meta-struct-info)
|
|
get-meta-struct-info)
|
|
|
|
(define (meta-struct? s)
|
|
(and (identifier? s)
|
|
(let ([v (syntax-local-value s (λ _ #f))])
|
|
(and v (struct-info? v)))))
|
|
|
|
(struct meta-struct-info
|
|
(type-descriptor
|
|
constructor
|
|
predicate
|
|
accessors
|
|
mutators
|
|
super-type)
|
|
#:transparent)
|
|
|
|
(define (get-meta-struct-info s #:srcloc [srcloc #f])
|
|
(if (meta-struct? s)
|
|
(apply meta-struct-info (extract-struct-info (syntax-local-value s)))
|
|
(raise-syntax-error 'get-struct-info
|
|
"not a structure definition"
|
|
(or srcloc s)
|
|
s))))
|
|
|
|
(require 'info
|
|
(for-syntax 'info))
|
|
|
|
(define-syntax (shorthand stx)
|
|
(syntax-case stx ()
|
|
[(_ base)
|
|
(with-syntax ([name (format-id #'base "meta-struct-~a" #'base)]
|
|
[accessor (format-id #'base "meta-struct-info-~a" #'base)]
|
|
[tmpl (format-id #'base "tmpl-struct-~a" #'base)])
|
|
#'(begin
|
|
(provide name tmpl)
|
|
(define-template-metafunction (tmpl stx)
|
|
(syntax-parse stx
|
|
[(_ s (~optional (~seq #:srcloc srcloc)))
|
|
(accessor
|
|
(get-meta-struct-info #'s #:srcloc (attribute srcloc)))]))
|
|
(define (name s #:srcloc [srcloc #f])
|
|
(accessor
|
|
(get-meta-struct-info s #:srcloc srcloc)))))]))
|
|
|
|
(shorthand type-descriptor)
|
|
(shorthand constructor)
|
|
(shorthand predicate)
|
|
(shorthand accessors)
|
|
(shorthand mutators)
|
|
(shorthand super-type)
|
|
|
|
(define-syntax (struct-predicate stx)
|
|
(syntax-case stx ()
|
|
[(_ s) (meta-struct-info-predicate (get-meta-struct-info #'s))]))
|
|
(define-syntax (struct-constructor stx)
|
|
(syntax-case stx ()
|
|
[(_ s) (meta-struct-info-constructor (get-meta-struct-info #'s))]))
|
|
(define-syntax (struct-accessor stx)
|
|
(syntax-case stx ()
|
|
[(_ s i) (list-ref (meta-struct-info-accessors (get-meta-struct-info #'s))
|
|
(syntax-e #'i))]))
|
|
|
|
(define (meta-struct-subtype? sub super)
|
|
(or (equal? (meta-struct-type-descriptor sub)
|
|
(meta-struct-type-descriptor super))
|
|
(let ((up (meta-struct-super-type sub)))
|
|
(and (meta-struct? up)
|
|
(meta-struct-subtype? up super)))))
|