(module tool-contract-language mzscheme
  (provide (rename -#%module-begin #%module-begin)
           (all-from-except mzscheme #%module-begin))
  
  (require (lib "contract.ss"))
  (require-for-syntax (lib "list.ss"))

  (define-syntax (-#%module-begin stx)
    
    (define-struct ctc-binding (var arg))
    (define-struct def-binding (var arg))
    
    (define (process-case case-stx)
      (syntax-case case-stx (define)
        [(define name expr)
         (identifier? (syntax name))
         (make-def-binding (syntax name) (syntax expr))]
        [(name type type-names strs ...)
         (and (identifier? (syntax name))
              (not (string? (syntax-object->datum (syntax type))))
              (andmap (λ (x) (string? (syntax-object->datum x))) (syntax->list (syntax (strs ...)))))
         (make-ctc-binding (syntax name) (syntax type))]
        [else (raise-syntax-error 'tool-contract-language.ss "unknown case" stx case-stx)]))
              
    
    (syntax-case stx ()
      [(_ cases ...)
       (let* ([pcases (map process-case (syntax->list (syntax (cases ...))))]
              [def-cases (filter def-binding? pcases)]
              [ctc-cases (filter ctc-binding? pcases)])
         (with-syntax ([(ctc-name ...) (map ctc-binding-var ctc-cases)]
                       [(ctc ...) (map ctc-binding-arg ctc-cases)]
                       [(def-name ...) (map def-binding-var def-cases)]
                       [(def-exp ...) (map def-binding-arg def-cases)]
                       [wrap-tool-inputs (datum->syntax-object stx 'wrap-tool-inputs #'here)])
           (syntax/loc stx
             (#%module-begin
              (provide wrap-tool-inputs)
              (define-syntax wrap-tool-inputs
                (λ (in-stx)
                  (syntax-case in-stx ()
                    [(_ body tool-name)
                     (let ([f (λ (in-obj) 
                                (datum->syntax-object 
                                 in-stx
                                 (syntax-object->datum in-obj)
                                 in-obj))])
                       (with-syntax ([(in-type (... ...)) (map f (syntax->list (syntax (ctc ...))))]
                                     [(in-name (... ...)) (map f (syntax->list (syntax (ctc-name ...))))]
                                     [(in-def-name (... ...)) (map f (syntax->list (syntax (def-name ...))))]
                                     [(in-def-exp (... ...)) (map f (syntax->list (syntax (def-exp ...))))])
                         (syntax/loc in-stx
                           (let ([in-def-name in-def-exp] (... ...))
                             (let ([in-name (contract (let ([in-name in-type]) in-name)
                                                      in-name
                                                      'drscheme
                                                      tool-name
                                                      (quote-syntax in-name))] (... ...))
                               body)))))])))))))]
      [(_ (name type type-names strs ...) ...)
       (begin
         (for-each
          (λ (str-stx)
            (when (string? (syntax-object->datum str-stx))
              (raise-syntax-error 'tool-contract-language.ss "expected type name specification"
                                  stx
                                  str-stx)))
          (syntax->list (syntax (type-names ...))))
         (for-each
          (λ (name)
            (unless (identifier? name)
              (raise-syntax-error 'tool-contract-language.ss "expected identifier" stx name)))
          (syntax->list (syntax (name ...))))
         (for-each
          (λ (str)
            (unless (string? (syntax-object->datum str))
              (raise-syntax-error 'tool-contract-language.ss "expected docs string" stx str)))
          (apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))]))
  
  (define-syntax (-#%module-begin2 stx)
    (syntax-case stx ()
      [(_ (name type type-names strs ...) ...)
       (and (andmap identifier? (syntax->list (syntax (name ...))))
            (andmap (λ (x) (not (string? (syntax-object->datum x))))
                    (syntax->list (syntax (type-names ...))))
            (andmap (λ (x) (string? (syntax-object->datum x)))
                    (apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))
       (with-syntax ([wrap-tool-inputs (datum->syntax-object stx 'wrap-tool-inputs #'here)])
         (syntax/loc stx
          (#%module-begin
           (provide wrap-tool-inputs)
           (define-syntax wrap-tool-inputs
             (λ (in-stx)
               (syntax-case in-stx ()
                 [(_ body tool-name)
                  (with-syntax ([(in-type (... ...))
                                 (map (λ (in-type-obj) 
                                        (datum->syntax-object 
                                         in-stx
                                         (syntax-object->datum in-type-obj)
                                         in-type-obj))
                                      (syntax->list (syntax (type ...))))]
                                [(in-name (... ...))
                                 (map (λ (in-name-obj) 
                                        (datum->syntax-object 
                                         in-stx 
                                         (syntax-object->datum in-name-obj)
                                         in-name-obj))
                                      (syntax->list (syntax (name ...))))])
                    (syntax/loc in-stx
                     (let ([in-name (contract (let ([in-name in-type]) in-name)
                                              in-name
                                              'drscheme
                                              tool-name
                                              (quote-syntax in-name))] (... ...))
                       body)))]))))))]
      [(_ (name type type-names strs ...) ...)
       (begin
         (for-each
          (λ (str-stx)
            (when (string? (syntax-object->datum str-stx))
              (raise-syntax-error 'tool-contract-language.ss "expected type name specification"
                                  stx
                                  str-stx)))
          (syntax->list (syntax (type-names ...))))
         (for-each
          (λ (name)
            (unless (identifier? name)
              (raise-syntax-error 'tool-contract-language.ss "expected identifier" stx name)))
          (syntax->list (syntax (name ...))))
         (for-each
          (λ (str)
            (unless (string? (syntax-object->datum str))
              (raise-syntax-error 'tool-contract-language.ss "expected docs string" stx str)))
          (apply append (map syntax->list (syntax->list (syntax ((strs ...) ...)))))))])))
