(module defstructure mzscheme

  (require-for-syntax (lib "etc.ss")
                      (lib "list.ss")
                      (file "literal-identifier=.scm")
                      "checking-proc.scm")
  (require "../define-below/define-below.ss")
  
  (provide defstructure)
  
  (define-syntax bool->CL
    (syntax-rules ()
      [(bool->CL x) (if x 't '())]))
  
  (define-for-syntax (->string x)
    (cond [(string? x) x]
          [(symbol? x) (symbol->string x)]
          [(identifier? x) (->string (syntax-e x))]
          [else (error '->string "Given ~a" x)]))
  
  (define-for-syntax sym+
    (case-lambda
      [(x) (string->symbol (->string x))]
      [(x y) (string->symbol (string-append (->string x) (->string y)))]
      [args (foldl sym+ "" (reverse args))]))
  
  (define-for-syntax (make-ctor-name name) name) 
  
  (define-for-syntax (make-weak-predicate-name name)
    (datum->syntax-object name (sym+ 'weak- name '-p)))
  
  (define-for-syntax (make-predicate-name name)
    (datum->syntax-object name (sym+ name '-p)))
  
  (define-for-syntax (field-spec->field-name fs)
    (syntax-case fs ()
      [fn (identifier? #'fn) #'fn]
      [(fn other-stuff ...) (identifier? #'fn) #'fn]
      [_ (raise-syntax-error #f "Not a field-spec" fs)]))
  
  (define-for-syntax (field-spec->field-kwd fs)
    (sym+ ': (field-spec->field-name fs)))
  
  (define-for-syntax (opt-specs->assertions fopts)
    (foldl (lambda (opt assertions)
             (syntax-case* opt (:assert) literal-identifier=?
               [(:assert assertion other-stuff ...) (cons #'assertion assertions)]
               [_ assertions]))
           '()
           fopts))
  
  (define-for-syntax (collect-field-assertions field-specs)
    (foldl (lambda (fs assertions) 
             (syntax-case fs ()
               [fname 
                (identifier? #'fname)
                assertions]
               [(fname options ...) 
                (append (opt-specs->assertions (syntax->list #'(options ...)))
                        assertions)]))
           '() field-specs))
  
  (define-for-syntax (make-selector-names name field-specs)
    (define (make-name field-spec)
      (datum->syntax-object name 
                            (sym+ name '- (field-spec->field-name field-spec))
                            ))
    (map make-name field-specs))
  
  (define-for-syntax (make-predicate name field-specs opt-specs)
    (with-syntax ([weak-predicate-name (make-weak-predicate-name name)]
                  [(selector ...) (make-selector-names name field-specs)]
                  [(fname ...) (map field-spec->field-name field-specs)]
                  [(fassertion ...) (collect-field-assertions field-specs)]
                  [(opt-assertion ...) (opt-specs->assertions opt-specs)])
      #'(lambda (object)
          (if (null? (weak-predicate-name object))
              '()
              (let-values ([(fname ...) (values (selector object) ...)])
                (bool->CL
                 (not (or (null? fassertion) ...
                          (null? opt-assertion) ...
                          ))))))))
  
  (define-for-syntax (make-field-offsets field-specs)
    (build-list (length field-specs) add1))
  
  (define-for-syntax (make-updater-name name)
    (datum->syntax-object name
                          (sym+ 'update- name)))
  
  ;; keyword keyword/value-list -> (union ACL2-value #f)
  ;; Produce the value to which the given keyword maps.
  ;; If the keyword is not mapped, produce #f.
  (define (extract-new-value kwd kwd/val-list)
    (cond [(memq kwd kwd/val-list) => cadr]
          [else #f]))
  
  (define-syntaxes (defstructure)
    (lambda (stx)
      (syntax-case stx (:options)
        [(defstructure name field-spec ...
           (:options opts ...))
         (with-syntax ([(formal ...) (generate-temporaries #'(field-spec ...))]
                       [ctor-name-id (make-ctor-name #'name)]
                       [weak-predicate-name-id (make-weak-predicate-name #'name)]
                       [predicate-name-id (make-predicate-name #'name)]
                       [predicate-fn (make-predicate #'name (syntax->list #'(field-spec ...))
                                                     (syntax->list #'(opts ...)))]
                       [(selector-name-id ...) 
                        (make-selector-names #'name (syntax->list 
                                                     #'(field-spec ...)))]
                       [updater-name-id
                        (make-updater-name #'name)]
                       [(field-kwd-id ...) (map field-spec->field-kwd
                                                (syntax->list #'(field-spec ...)))]
                       [(offset-num ...) (make-field-offsets 
                                          (syntax->list #'(field-spec ...)))])
           (with-syntax ([(internal-ctor internal-weak internal-pred internal-updater) 
                          (generate-temporaries #'(ctor-name-id weak-predicate-name-id
                                                                predicate-name-id
                                                                updater-name-id))]
                         [(internal-selector ...)
                          (generate-temporaries #'(selector-name-id ...))])
             #'(begin
                 (define-below (internal-ctor formal ...)
                   (list (quote name) formal ...))
                 (define-below (internal-weak x)
                   (bool->CL
                    (and (list? x) 
                         (= (length x) (length (quote (name offset-num ...))))
                         (eq? (car x) (quote name)))))
                 (define-values-below (internal-selector ...)
                   (values (lambda (x) (list-ref x offset-num)) ...))
                 (define-below internal-pred 
                   (let-syntax ([weak-predicate-name-id
                                 (syntax-rules ()
                                   [(_ e) (internal-weak e)])]
                                [selector-name-id 
                                 (syntax-rules ()
                                   [(_ e) (internal-selector e)])]
                                ...)
                     predicate-fn))
                   
                 ;; FIX:  Need to do more static checking.  In ACL2, the
                 ;; updater is a macro that expects a literal kwd/val-list
                 ;; and it checks that the keywords are all really field
                 ;; names. 
                 (define-below internal-updater
                   (let-syntax ([ctor-name-id 
                                 (syntax-rules ()
                                   [(_ formal ...) (internal-ctor formal ...)])]
                                [selector-name-id 
                                 (syntax-rules ()
                                   [(_ e) (internal-selector e)])]
                                ...)
                     (lambda (obj . kwd/val-list)
                       ;; kwd/val-list : alternating list of kwds and values
                       (ctor-name-id
                        (or (extract-new-value 'field-kwd-id kwd/val-list)
                            (selector-name-id obj))
                        ...))))
                 (define-syntaxes (ctor-name-id
                                   weak-predicate-name-id
                                   predicate-name-id
                                   selector-name-id ...
                                   updater-name-id)  
                   (values (checking-proc internal-ctor (formal ...))
                           (checking-proc internal-weak (x))
                           (checking-proc internal-pred (x))
                           (checking-proc internal-selector (x))
                           ...
                           ;; this one is multi-arg, so don't arity-check
                           ;; like the others:
                           (lambda (stx)
                             (syntax-case stx ()
                               [(_ignore)
                                (raise-syntax-error
                                 #f
                                 "Structure updater needs a structure to update"
                                 stx)]
                               [(_ignore obj kwd/val (... ...))
                                #'(internal-updater obj kwd/val (... ...))]
                               [_else 
                                (raise-syntax-error 
                                 #f 
                                 "Functions may be used only in operator position."
                                 stx)]))
                           )))))]
        [(defstructure name field-spec ...)
         #'(defstructure name field-spec ... (:options))]
        [_ (raise-syntax-error 
            #f
            (format "Expected a structure name followed by field names, but got ~a"
                    (syntax-object->datum stx))
            stx)]
        )))
  
  )