#lang scheme
(require (for-syntax syntax/parse
                     scheme/match
                     scheme/list
                     scheme/local
                     unstable/syntax
                     "sstruct-syn.ss"))

(define-syntax (define-sstruct stx)
  (syntax-parse
   stx
   [(_ id:id-maybe-super
       (f:field ...)
       (~or (~optional (~seq #:constructor constructor:id)
                       #:defaults ([constructor #'id.name]))
            (~optional (~seq #:predicate predicate:id)
                       #:defaults ([predicate (format-id #'id.name "~a?" #'id.name)]))
            (~optional (~and (~bind [mutable? #t])
                             #:mutable)
                       #:defaults ([mutable? #f]))
            (~optional #:omit-define-syntaxes)
            (~optional #:omit-define-values))
       ...)
    (local [(define struct-mutable? (attribute mutable?))
            (define parent-formals
              (if (attribute id.parent-desc)
                  (sstruct-description-formals (attribute id.parent-desc))
                  #'()))]
      (with-syntax ([the-constructor (generate-temporary #'constructor)]
                    [super-struct-type
                     (if (attribute id.parent-desc)
                         (sstruct-description-struct-type-id (attribute id.parent-desc))
                         #f)]
                    [(parent-field-name ...)
                     (if (attribute id.parent-desc)
                         (sstruct-description-field-names (attribute id.parent-desc))
                         empty)]
                    [(parent-pos-field-name ...)
                     (if (attribute id.parent-desc)
                         (sstruct-description-by-pos-field-names (attribute id.parent-desc))
                         empty)]
                    [((parent-kw-field-kw parent-kw-field-name) ...)
                     (if (attribute id.parent-desc)
                         (sstruct-description-by-kw-fields (attribute id.parent-desc))
                         empty)]
                    [(parent-field-accessor ...)
                     (if (attribute id.parent-desc)
                         (sstruct-description-field-accessors (attribute id.parent-desc))
                         empty)]
                    ; XXX allow override
                    [struct:struct (format-id #'id.name "struct:~a" #'id.name)]
                    [how-many-fields (length (syntax->list #'(f ...)))]
                    [(f-pos ...) (for/list ([i (in-naturals)]
                                            [f (in-list (syntax->list #'(f ...)))])
                                   i)]
                    [(immutable-field-number ...)
                     (for/list ([field-mutable? (in-list (attribute f.mutable?))]
                                [i (in-naturals)]
                                #:when (not (or struct-mutable? field-mutable?)))
                       i)]
                    [(f:accessor ...)
                     (for/list ([accessor (in-list (attribute f.accessor))]
                                [name (in-list (syntax->list #'(f.name ...)))])
                       (or accessor (format-id #'id.name "~a-~a" #'id.name name)))]
                    [((mutable-f:mutator mutable-f-pos) ...)
                     (for/list ([field-mutable? (in-list (attribute f.mutable?))]
                                [mutator (in-list (attribute f.mutator))]
                                [name (in-list (syntax->list #'(f.name ...)))]
                                [i (in-naturals)]
                                #:when (or struct-mutable? field-mutable?))
                       (list (or mutator (format-id #'id.name "set-~a-~a!" #'id.name name))
                             i))]
                    [(pos-field-name ...)
                     (for/list ([kw (in-list (attribute f.kw))]
                                [name (in-list (attribute f.name))]
                                #:when (not kw))
                       name)]
                    [((kw-field-kw kw-field-name) ...)
                     (for/list ([kw (in-list (attribute f.kw))]
                                [name (in-list (attribute f.name))]
                                #:when kw)
                       (list kw name))]
                    [constructor-formals
                     (for/fold ([formals parent-formals])
                       ([kw (in-list (attribute f.kw))]
                        [name (in-list (attribute f.name))]
                        [default-value (in-list (attribute f.default-value))])
                       (quasisyntax/loc stx
                         (#,@formals
                          #,@(if kw (list kw) empty)
                          #,(if default-value (list name default-value) name))))])
        (syntax/loc stx
          (begin
            (define-values 
              (struct-type struct-constructor struct-predicate struct-accessor struct-mutator)
              (make-struct-type 'id.name
                                super-struct-type
                                how-many-fields
                                0 ; xxx auto fields
                                #f ; xxx auto value
                                empty ; xxx props
                                (current-inspector) ; xxx inspector
                                #f ; xxx proc spec
                                (list immutable-field-number ...)
                                #f ; xxx guard
                                ))
            
            (define the-constructor 
              (lambda constructor-formals
                (struct-constructor parent-field-name ... f.name ...)))
            (define predicate struct-predicate)
            (define (f:accessor s)
              (struct-accessor s f-pos))
            ...
            (define (mutable-f:mutator s v)
              (struct-mutator s mutable-f-pos v))
            ...
            
            (define-syntax struct:struct
              (make-sstruct-description 
               #'struct-type 
               #'(f.name ...) #'(f:accessor ...)
               #'(parent-pos-field-name ... pos-field-name ...)
               #'((parent-kw-field-kw parent-kw-field-name) ...
                  (kw-field-kw kw-field-name) ...)
               #'constructor-formals))
            
            (define-match-expander constructor
              (lambda (stx)
                (syntax-case stx ()
                  [(_ . content)
                   (local [(define-values (ids kws) (separate-keywords #'content))]
                     (syntax-parse 
                      (list* 'hack kws)
                      [((~or (~datum hack)
                             (~once (parent-kw-field-kw parent-kw-field-name))
                             ...
                             (~once (kw-field-kw kw-field-name))
                             ...)
                        (... ...))
                       (with-syntax ([(parent-pos-field-name ... pos-field-name ...) ids])
                         
                         (syntax/loc stx
                           (? struct-predicate
                              (and (app parent-field-accessor parent-field-name)
                                   ...
                                   (app f:accessor f.name)
                                   ...))))]))]))
              (lambda (stx)
                (syntax-case
                    stx ()
                  [(_ a (... ...)) #'(the-constructor a (... ...))]
                  [_ #'the-constructor])))))))]))

(provide define-sstruct)

(define-sstruct a (#:x x))

(match (a #:x 5)
  [(a #:x x) x])