<commit_before>#lang scheme/base

#|

v4 todo:

- add case-> to object-contract

- test object-contract with keywords (both optional and mandatory)

- change mzlib/contract to rewrite into scheme/contract (maybe?)

- raise-syntax-errors
  . multiple identical keywords syntax error, sort-keywords
  . split-doms

- note timing/size tests at the end of the file.

|#

(require "contract-guts.ss"
         "contract-opt.ss"
         scheme/stxparam)
(require (for-syntax scheme/base)
         (for-syntax "contract-opt-guts.ss")
         (for-syntax "contract-helpers.ss")
         (for-syntax syntax/stx)
         (for-syntax syntax/name))

(provide ->
         ->*
         ->d
         case->
         unconstrained-domain->
         the-unsupplied-arg 
         making-a-method
         procedure-accepts-and-more?
         check-procedure
         check-procedure/more)

(define-syntax-parameter making-a-method #f)

(define-syntax (unconstrained-domain-> stx)
  (syntax-case stx ()
    [(_ rngs ...)
     (with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
                   [(proj-x ...) (generate-temporaries #'(rngs ...))]
                   [(p-app-x ...) (generate-temporaries #'(rngs ...))]
                   [(res-x ...) (generate-temporaries #'(rngs ...))])
       #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
           (let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
             (make-proj-contract
              (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
              (λ (pos-blame neg-blame src-info orig-str)
                (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
                  (λ (val)
                    (if (procedure? val)
                        (make-keyword-procedure
                         (λ (kwds kwd-vals . args)
                           (let-values ([(res-x ...) (keyword-apply val kwds kwd-vals args)])
                             (values (p-app-x res-x) ...)))
                         (λ args
                           (let-values ([(res-x ...) (apply val args)])
                             (values (p-app-x res-x) ...))))
                        (raise-contract-error val
                                              src-info
                                              pos-blame
                                              orig-str
                                              "expected a procedure")))))
              procedure?))))]))


;              
;              
;              
;         ;    
;          ;   
;           ;  
;   ;;;;;;;;;; 
;           ;  
;          ;   
;         ;    
;              
;              
;              
;              


(define (build--> name
                  doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f 
                  mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
                  rngs/c-or-p
                  rng-any? func)
  (let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
    (make--> 
     (map cc doms/c-or-p) (map cc optional-doms/c-or-p) (and doms-rest/c-or-p-or-f (cc doms-rest/c-or-p-or-f))
     (map cc mandatory-kwds/c-or-p) mandatory-kwds (map cc optional-kwds/c-or-p) optional-kwds
     (map cc rngs/c-or-p) rng-any?
     func)))

;; doms : (listof contract)
;; optional-doms/c : (listof contract)
;; dom-rest : (or/c false/c contract)
;; mandatory-kwds/c : (listof contract)
;; mandatory-kwds : (listof keyword) -- must be sorted by keyword<
;; optional-kwds/c : (listof contract)
;; optional-kwds : (listof keyword) -- must be sorted by keyword<
;; rngs : (listof contract) -- may be ignored by the wrapper function in the case of any
;; rng-any? : boolean
;; func : the wrapper function maker. It accepts a procedure for
;;        checking the first-order properties and the contracts
;;        and it produces a wrapper-making function.
(define-struct/prop -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func)
  ((proj-prop (λ (ctc) 
                (let* ([doms-proj (map (λ (x) ((proj-get x) x)) 
                                       (if (->-dom-rest/c ctc)
                                           (append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
                                           (->-doms/c ctc)))]
                       [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))]
                       [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))]
                       [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))]
                       [optional-kwds-proj (map (λ (x) ((proj-get x) x)) (->-optional-kwds/c ctc))]
                       [mandatory-keywords (->-mandatory-kwds ctc)]
                       [optional-keywords (->-optional-kwds ctc)]
                       [func (->-func ctc)]
                       [dom-length (length (->-doms/c ctc))]
                       [optionals-length (length (->-optional-doms/c ctc))]
                       [has-rest? (and (->-dom-rest/c ctc) #t)])
                  (λ (pos-blame neg-blame src-info orig-str)
                    (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
                                             doms-proj)]
                          [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
                                                      doms-optional-proj)]
                          [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
                                               rngs-proj)]
                          [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
                                                       mandatory-kwds-proj)]
                          [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
                                                      optional-kwds-proj)])
                      (apply func
                             (λ (val mtd?)
                               (if has-rest?
                                   (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
                                   (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
                             (append partial-doms partial-optional-doms 
                                     partial-mandatory-kwds partial-optional-kwds
                                     partial-ranges)))))))
   (name-prop (λ (ctc) (single-arrow-name-maker 
                        (->-doms/c ctc)
                        (->-optional-doms/c ctc)<commit_msg>Add which argument or result caused the contract error for -> contracts (i.e. also ->*, but not ->d or case->).<commit_after>#lang scheme/base

#|

v4 todo:

- add case-> to object-contract

- test object-contract with keywords (both optional and mandatory)

- change mzlib/contract to rewrite into scheme/contract (maybe?)

- raise-syntax-errors
  . multiple identical keywords syntax error, sort-keywords
  . split-doms

- note timing/size tests at the end of the file.

|#

(require "contract-guts.ss"
         "contract-opt.ss"
         scheme/stxparam)
(require (for-syntax scheme/base)
         (for-syntax "contract-opt-guts.ss")
         (for-syntax "contract-helpers.ss")
         (for-syntax syntax/stx)
         (for-syntax syntax/name))

(provide ->
         ->*
         ->d
         case->
         unconstrained-domain->
         the-unsupplied-arg 
         making-a-method
         procedure-accepts-and-more?
         check-procedure
         check-procedure/more)

(define-syntax-parameter making-a-method #f)

(define-syntax (unconstrained-domain-> stx)
  (syntax-case stx ()
    [(_ rngs ...)
     (with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
                   [(proj-x ...) (generate-temporaries #'(rngs ...))]
                   [(p-app-x ...) (generate-temporaries #'(rngs ...))]
                   [(res-x ...) (generate-temporaries #'(rngs ...))])
       #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
           (let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
             (make-proj-contract
              (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
              (λ (pos-blame neg-blame src-info orig-str)
                (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
                  (λ (val)
                    (if (procedure? val)
                        (make-keyword-procedure
                         (λ (kwds kwd-vals . args)
                           (let-values ([(res-x ...) (keyword-apply val kwds kwd-vals args)])
                             (values (p-app-x res-x) ...)))
                         (λ args
                           (let-values ([(res-x ...) (apply val args)])
                             (values (p-app-x res-x) ...))))
                        (raise-contract-error val
                                              src-info
                                              pos-blame
                                              orig-str
                                              "expected a procedure")))))
              procedure?))))]))


;              
;              
;              
;         ;    
;          ;   
;           ;  
;   ;;;;;;;;;; 
;           ;  
;          ;   
;         ;    
;              
;              
;              
;              


(define (build--> name
                  doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f 
                  mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
                  rngs/c-or-p
                  rng-any? func)
  (let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
    (make--> 
     (map cc doms/c-or-p) (map cc optional-doms/c-or-p) (and doms-rest/c-or-p-or-f (cc doms-rest/c-or-p-or-f))
     (map cc mandatory-kwds/c-or-p) mandatory-kwds (map cc optional-kwds/c-or-p) optional-kwds
     (map cc rngs/c-or-p) rng-any?
     func)))

;; doms : (listof contract)
;; optional-doms/c : (listof contract)
;; dom-rest : (or/c false/c contract)
;; mandatory-kwds/c : (listof contract)
;; mandatory-kwds : (listof keyword) -- must be sorted by keyword<
;; optional-kwds/c : (listof contract)
;; optional-kwds : (listof keyword) -- must be sorted by keyword<
;; rngs : (listof contract) -- may be ignored by the wrapper function in the case of any
;; rng-any? : boolean
;; func : the wrapper function maker. It accepts a procedure for
;;        checking the first-order properties and the contracts
;;        and it produces a wrapper-making function.
(define-struct/prop -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func)
  ((proj-prop (λ (ctc) 
                (let* ([doms-proj (map (λ (x) ((proj-get x) x)) (->-doms/c ctc))]
                       [rest-proj ((λ (x) (and x ((proj-get x) x))) (->-dom-rest/c ctc))]
                       [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))]
                       [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))]
                       [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))]
                       [optional-kwds-proj (map (λ (x) ((proj-get x) x)) (->-optional-kwds/c ctc))]
                       [mandatory-keywords (->-mandatory-kwds ctc)]
                       [optional-keywords (->-optional-kwds ctc)]
                       [func (->-func ctc)]
                       [dom-length (length (->-doms/c ctc))]
                       [optionals-length (length (->-optional-doms/c ctc))])
                  (λ (pos-blame neg-blame src-info orig-str)
                    (let ([partial-doms (for/list ([dom doms-proj]
                                                   [n (in-naturals 1)]) 
                                          (dom neg-blame pos-blame src-info
                                               (format "required argument ~a of ~a" n orig-str)))]
                          [partial-rest (if rest-proj
                                            (list (rest-proj neg-blame pos-blame src-info
                                                             (format "rest argument of ~a" orig-str)))
                                            null)]
                          [partial-optional-doms (for/list ([dom doms-optional-proj]
                                                            [n (in-naturals 1)])
                                                   (dom neg-blame pos-blame src-info
                                                        (format "optional argument ~a of ~a"
                                                                n orig-str)))]
                          [partial-ranges (for/list ([rng rngs-proj]
                                                     [n (in-naturals 1)])
                                            (rng pos-blame neg-blame src-info
                                                 (format "result ~a of ~a" n orig-str)))]
                          [partial-mandatory-kwds (for/list ([kwd mandatory-kwds-proj]
                                                             [kwd-lit mandatory-keywords])
                                                    (kwd neg-blame pos-blame src-info
                                                         (format "keyword argument ~a of ~a"
                                                                 kwd-lit orig-str)))]
                          [partial-optional-kwds (for/list ([kwd optional-kwds-proj]
                                                            [kwd-lit optional-keywords])
                                                   (kwd neg-blame pos-blame src-info
                                                        (format "keyword argument ~a of ~a"
                                                                kwd-lit orig-str)))])
                      (apply func
                             (λ (val mtd?)
                               (if rest-proj
                                   (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
                                   (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
                             (append partial-doms partial-rest partial-optional-doms 
                                     partial-mandatory-kwds partial-optional-kwds
                                     partial-ranges)))))))
   (name-prop (λ (ctc) (single-arrow-name-maker 
                        (->-doms/c ctc)
                        (->-optional-doms/c ctc)
{'fraction_non_alphanumeric': 0.13528311965811965, 'fraction_numerical': 0.0003338675213675214, 'mean_word_length': 1.1374339945768517, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 60, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 84, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4320144', 'n_tokens_mistral': 4448, 'n_tokens_neox': 4151, 'n_words': 982}