#lang racket/base

(require (for-syntax racket/base
                     racket/list
                     racket/struct-info)
         racket/list
         "guts.rkt"
         "blame.rkt"
         "prop.rkt")

(provide struct/c)

(define-syntax (struct/c stx)
  (syntax-case stx ()
    [(_ . args) 
     (with-syntax ([x (syntax/loc stx (do-struct/c . args))])
       (syntax/loc stx (#%expression x)))]))

;; name is symbol
;; predicate is (-> any bool)
;; immutables is (listof (list natural contract selector-proc))
;; mutables is (listof (list natural contract selector-proc mutator-proc))
(define-struct base-struct/c (name predicate immutables mutables))

(define (struct/c-name ctc)
  (let ([ctcs (map second
                   (sort (append (base-struct/c-immutables ctc) (base-struct/c-mutables ctc))
                         < #:key first))])
    (apply build-compound-type-name 'struct/c (base-struct/c-name ctc) ctcs)))

(define (check-struct/c ctc)
  (let ([name (base-struct/c-name ctc)]
        [pred? (base-struct/c-predicate ctc)]
        [ctc/ref-pairs (map (λ (l) (cons (second l) (third l)))
                            (append (base-struct/c-immutables ctc) (base-struct/c-mutables ctc)))])
    (λ (val fail [first-order? #f])
      (unless (pred? val)
        (fail "expected <~a>, got ~e" name val))
      (when first-order?
        (for ([p (in-list ctc/ref-pairs)])
          (let ([c (car p)] [v ((cdr p) val)])
            (unless (contract-first-order-passes? c v)
              (fail "expected <~a>, got ~e" (contract-name c) v)))))
      #t)))

(define (struct/c-first-order ctc)
  (let ([f (check-struct/c ctc)])
    (λ (val)
      (let/ec fail
        (f val (λ args (fail #f)) #t)))))

(define (flat-struct/c-proj ctc)
  (let ([checker (check-struct/c ctc)]
        [name (base-struct/c-name ctc)]
        [pred (base-struct/c-predicate ctc)]
        [projs (map contract-projection (map second (base-struct/c-immutables ctc)))]
        [refs (map third (base-struct/c-immutables ctc))])
    (λ (blame)
      (let ([pos-projs (map (λ (f) (f blame)) projs)])
        (λ (val)
          (checker val (λ args (apply raise-blame-error blame val args)))
          (for ([p (in-list pos-projs)] [ref (in-list refs)])
            (p (ref val)))
          val)))))

(define-struct (flat-struct/c base-struct/c) ()
  #:property prop:flat-contract
  (build-flat-contract-property
   #:name struct/c-name
   #:first-order struct/c-first-order
   #:projection flat-struct/c-proj))

(define (chaperone-struct/c-proj ctc)
  (let-values ([(flat-imms chap-imms)
                (partition (λ (l) (flat-contract? (second l))) (base-struct/c-immutables ctc))])
    (let ([checker (check-struct/c ctc)]
          [name (base-struct/c-name ctc)]
          [pred (base-struct/c-predicate ctc)]
          [flat-imm-projs (map (compose contract-projection second) flat-imms)]
          [flat-imm-refs (map third flat-imms)]
          [chap-imm-projs (map (compose contract-projection second) chap-imms)]
          [chap-imm-refs (map third chap-imms)]
          [mut-projs (map (compose contract-projection second) (base-struct/c-mutables ctc))]
          [mut-refs (map third (base-struct/c-mutables ctc))]
          [mut-sets (map fourth (base-struct/c-mutables ctc))])
      (λ (blame)
        (let* ([swapped-blame (blame-swap blame)]
               [flat-imm-pos-projs (map (λ (f) (f blame)) flat-imm-projs)]
               [chap-imm-pos-projs (map (λ (f) (f blame)) chap-imm-projs)]
               [mut-pos-projs (map (λ (f) (f blame)) mut-projs)]
               [mut-neg-projs (map (λ (f) (f swapped-blame)) mut-projs)])
          (λ (val)
            (checker val (λ args (apply raise-blame-error blame val args)))
            (for ([p (in-list flat-imm-pos-projs)]
                  [ref (in-list flat-imm-refs)])
              (p (ref val)))
            ;; While gathering up the selectors and the appropriate projections,
            ;; we go ahead and apply the projection to check the first order properties.
            (let ([combined-imm-refs 
                   (for/list ([p (in-list chap-imm-pos-projs)]
                              [ref (in-list chap-imm-refs)])
                     (p (ref val))
                     (list ref (λ (s v) (p v))))]
                  [combined-mut-refs
                   (for/list ([p (in-list mut-pos-projs)]
                              [ref (in-list mut-refs)])
                     (p (ref val))
                     (list ref (λ (s v) (p v))))]
                  [combined-mut-sets
                   (for/list ([p (in-list mut-neg-projs)]
                              [set (in-list mut-sets)])
                     (list set (λ (s v) (p v))))])
              (apply chaperone-struct val
                     (flatten (list combined-imm-refs combined-mut-refs combined-mut-sets
                                    impersonator-prop:contracted ctc))))))))))

(define-struct (chaperone-struct/c base-struct/c) ()
  #:property prop:chaperone-contract
  (build-chaperone-contract-property
   #:name struct/c-name
   #:first-order struct/c-first-order
   #:projection chaperone-struct/c-proj))

(define (impersonator-struct/c-proj ctc)
  (let-values ([(flat-imms chap-imms)
                (partition (λ (l) (flat-contract? (second l))) (base-struct/c-immutables ctc))])
    (let ([checker (check-struct/c ctc)]
          [name (base-struct/c-name ctc)]
          [pred (base-struct/c-predicate ctc)]
          [flat-imm-projs (map (compose contract-projection second) flat-imms)]
          [flat-imm-refs (map third flat-imms)]
          [chap-imm-projs (map (compose contract-projection second) chap-imms)]
          [chap-imm-refs (map third chap-imms)]
          [mut-projs (map (compose contract-projection second) (base-struct/c-mutables ctc))]
          [mut-refs (map third (base-struct/c-mutables ctc))]
          [mut-sets (map fourth (base-struct/c-mutables ctc))])
      (λ (blame)
        (let* ([swapped-blame (blame-swap blame)]
               [flat-imm-pos-projs (map (λ (f) (f blame)) flat-imm-projs)]
               [chap-imm-pos-projs (map (λ (f) (f blame)) chap-imm-projs)]
               [mut-pos-projs (map (λ (f) (f blame)) mut-projs)]
               [mut-neg-projs (map (λ (f) (f swapped-blame)) mut-projs)])
          (λ (val)
            (checker val (λ args (apply raise-blame-error blame val args)))
            (for ([p (in-list flat-imm-pos-projs)]
                  [ref (in-list flat-imm-refs)])
              (p (ref val)))
            ;; While gathering up the selectors and the appropriate projections,
            ;; we go ahead and apply the projection to check the first order properties.
            (let ([combined-imm-refs 
                   (for/list ([p (in-list chap-imm-pos-projs)]
                              [ref (in-list chap-imm-refs)])
                     (p (ref val))
                     (list ref (λ (s v) (p v))))]
                  [combined-mut-refs
                   (for/list ([p (in-list mut-pos-projs)]
                              [ref (in-list mut-refs)])
                     (p (ref val))
                     (list ref (λ (s v) (p v))))]
                  [combined-mut-sets
                   (for/list ([p (in-list mut-neg-projs)]
                              [set (in-list mut-sets)])
                     (list set (λ (s v) (p v))))])
              (apply impersonate-struct
                     (apply chaperone-struct val
                            combined-imm-refs)
                     (flatten (list combined-mut-refs combined-mut-sets
                                    impersonator-prop:contracted ctc))))))))))

(define-struct (impersonator-struct/c base-struct/c) ()
  #:property prop:contract
  (build-contract-property
   #:name struct/c-name
   #:first-order struct/c-first-order
   #:projection impersonator-struct/c-proj))

(define-syntax (do-struct/c stx)
  (syntax-case stx ()
    [(_ struct-name args ...)
     (and (identifier? (syntax struct-name))
          (struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
     (let* ([si (extract-struct-info (syntax-local-value (syntax struct-name)))]
            [predicate-id (third si)]
            [selector-ids (reverse (fourth si))]
            [mutator-ids (reverse (fifth si))]
            [ctcs (syntax->list #'(args ...))]
            [ctc-names (generate-temporaries #'(args ...))])
       (unless (= (length selector-ids) (length ctcs))
         (raise-syntax-error 'struct/c 
                             (format "expected ~a contracts because struct ~a has ~a fields"
                                     (length selector-ids)
                                     (syntax-e #'struct-name)
                                     (length selector-ids))
                             stx))
       (unless predicate-id
         (error 'struct/c "could not determine predicate for ~s" 'struct-name))
       (unless (andmap values selector-ids)
         (error 'struct/c "could not determine selectors for ~s" 'struct-name))
       
       (let ([combined-ids (for/list ([n (in-naturals)]
                                      [ctc-name (in-list ctc-names)]
                                      [ref-name (in-list selector-ids)]
                                      [mut-name (in-list mutator-ids)])
                             (list n ctc-name ref-name mut-name))])
         (let-values ([(mutables immutables) (partition (λ (l) (fourth l)) combined-ids)])
           (with-syntax ([(ctc-x ...) ctc-names]
                         [predicate-id predicate-id]
                         [((imm-count imm-ctc-x imm-ref _) ...) immutables]
                         [((mut-count mut-ctc-x mut-ref mut-set) ...) mutables])
             (syntax
              (let ([ctc-x (coerce-contract 'struct/c args)] ...)
                
                (unless (chaperone-contract? imm-ctc-x)
                  (error 'struct/c "expected a chaperone contract for immutable field ~v, got ~e"
                         imm-count imm-ctc-x))
                ...
                
                (let ([immutables (list (list imm-count imm-ctc-x imm-ref) ...)]
                      [mutables (list (list mut-count mut-ctc-x mut-ref mut-set) ...)])
                  (cond
                    [(and (null? mutables) (andmap (λ (l) (flat-contract? (second l))) immutables))
                     (make-flat-struct/c 'struct-name predicate-id immutables mutables)]
                    [(andmap (λ (l) (chaperone-contract? (second l))) mutables)
                     (make-chaperone-struct/c 'struct-name predicate-id immutables mutables)]
                    [else
                     (make-impersonator-struct/c 'struct-name predicate-id immutables mutables)]))))))))]
    [(_ struct-name anything ...)
     (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
