#lang scheme
(require syntax/parse)

(define (separate-keywords stx)
  (let loop ([ids empty]
             [kws empty]
             [stx stx])
    (syntax-parse
     stx
     [(kw:keyword arg:id . rst)
      (loop ids (list* (list #'kw #'arg) kws) #'rst)]
     [(arg:id . rst)
      (loop (list* #'arg ids) kws #'rst)]
     [()
      (values (reverse ids) kws)])))

(define-struct sstruct-description 
  (struct-type-id field-names field-accessors
                  by-pos-field-names
                  by-kw-fields
                  formals))

(define-syntax-class id-maybe-super
  #:attributes (name parent-desc)
  #:description "identifier or identifier and super"
  (pattern name:id
           #:attr parent-desc #f)
  (pattern (name:id parent)
           #:declare parent (static sstruct-description? "struct description")
           #:attr parent-desc (attribute parent.value)))

(define-syntax-class field-name+options
  #:attributes (name mutable? accessor mutator default-value)
  #:description "field specification"
  (pattern name:id
           #:attr mutable? #f
           #:attr accessor #f
           #:attr mutator #f
           #:attr default-value #f)
  ; XXX add too-many errors
  (pattern (name:id 
            (~or (~optional (~and (~bind [mutable? #t])
                                  #:mutable)
                            #:defaults ([mutable? #f]))
                 (~optional (~seq #:accessor accessor:id)
                            #:defaults ([accessor #f]))
                 (~optional (~seq #:mutator mutator:id)
                            #:defaults ([mutator #f]))
                 (~optional default-value:expr
                            #:defaults ([default-value #f])))
            ...)))

(define-splicing-syntax-class field
  #:attributes (kw name mutable? accessor mutator default-value)
  #:description "field specification"
  (pattern (~seq kw:keyword name+options:field-name+options)
           #:attr name #'name+options.name
           #:attr mutable? (attribute name+options.mutable?)
           #:attr accessor (attribute name+options.accessor)
           #:attr mutator (attribute name+options.mutator)
           #:attr default-value (attribute name+options.default-value))
  (pattern name+options:field-name+options
           #:attr kw #f
           #:attr name #'name+options.name
           #:attr mutable? (attribute name+options.mutable?)
           #:attr accessor (attribute name+options.accessor)
           #:attr mutator (attribute name+options.mutator)
           #:attr default-value (attribute name+options.default-value)))

(provide (all-defined-out))