#lang zuo/datum
(require "and-or.zuo"
         "syntax-error.zuo"
         "../pair.zuo"
         "../list.zuo"
         "define.zuo"
         "let.zuo"
         "quasiquote.zuo"
         "../more.zuo")

(provide struct)

(define-syntax struct
  (lambda (stx)
    (unless (and (list? stx)
                 (= (length stx) 3)
                 (identifier? (cadr stx)))
      (bad-syntax stx))
    (define name (cadr stx))
    (define fields (cadr (cdr stx)))
    (unless (and (list? fields)
                 (andmap identifier? fields))
      (bad-syntax stx))
    (define key `(,(quote-syntax quote)
                  ,(string->uninterned-symbol (symbol->string (syntax-e name)))))
    (define name? (string->symbol (datum->syntax name (~a (syntax-e name) "?"))))
    `(,(quote-syntax begin)
      (,(quote-syntax define) ,name
                              (,(quote-syntax lambda)
                               ,fields
                               (,(quote-syntax opaque) ,key
                                                       (,(quote-syntax list) ,@fields))))
      (,(quote-syntax define) (,name? v) (,(quote-syntax and)
                                          (,(quote-syntax opaque-ref) ,key v #f)
                                          #t))
      ,@(let loop ([fields fields] [index 0])
          (cond
            [(null? fields) '()]
            [else
             (let ([field (car fields)])
               (let ([ref (datum->syntax field (string->symbol (~a (syntax-e name)
                                                                   "-"
                                                                   (syntax-e field))))]
                     [set (datum->syntax field (string->symbol (~a (syntax-e name)
                                                                   "-set-"
                                                                   (syntax-e field))))])
                 (define mk
                   (lambda (head res)
                     `(,(quote-syntax define) ,head
                                              (,(quote-syntax let)
                                               ([c (,(quote-syntax opaque-ref) ,key v #f)])
                                               (,(quote-syntax if)
                                                c
                                                ,res
                                                (,(quote-syntax arg-error)
                                                 (,(quote-syntax quote) ,(car head))
                                                 ,(symbol->string (syntax-e name))
                                                 v))))))
                 (cons
                  `(,(quote-syntax begin)
                    ,(mk `(,ref v) `(,(quote-syntax list-ref) c ,index))
                    ,(mk `(,set v a) `(,(quote-syntax opaque) ,key (,(quote-syntax list-set) c ,index a))))
                  (loop (cdr fields)
                        (+ index 1)))))])))))
