bkyk8rc3zvpnsf5inmcqq4n3k98cv6hj-my-site-hyper-literate-git.test.suzanne.soy-0.0.1

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

provide-structs.rkt (1486B)

      1 #lang scheme/base
      2 (require scheme/serialize
      3          racket/contract/base
      4          (for-syntax scheme/base))
      5 
      6 (provide provide-structs)
      7 
      8 (define-syntax (provide-structs stx)
      9   (syntax-case stx ()
     10     [(_ (id ([field ct] ...)) ...)
     11      #`(begin
     12          (define-serializable-struct id (field ...) #:transparent) ...
     13          (provide/contract
     14           #,@(let ([ids (syntax->list #'(id ...))]
     15                    [fields+cts (syntax->list #'(([field ct] ...) ...))])
     16                (define (get-fields super-id)
     17                  (ormap (lambda (id  fields+cts)
     18                           (if (identifier? id)
     19                             (and (free-identifier=? id super-id)
     20                                  fields+cts)
     21                             (syntax-case id ()
     22                               [(my-id next-id)
     23                                (free-identifier=? #'my-id super-id)
     24                                #`[#,@(get-fields #'next-id)
     25                                   #,@fields+cts]]
     26                               [_else #f])))
     27                         ids fields+cts))
     28                (map (lambda (id fields+cts)
     29                       (if (identifier? id)
     30                         #`[struct #,id #,fields+cts]
     31                         (syntax-case id ()
     32                           [(id super)
     33                            #`[struct id (#,@(get-fields #'super) 
     34                                          #,@fields+cts)]])))
     35                     ids
     36                     fields+cts))))]))
     37