<commit_before>#lang racket/base
(require (for-syntax racket/base))

(provide test/no-error
         test/spec-passed
         test/spec-passed/result
         test/spec-failed
         test/pos-blame
         test/neg-blame
         test/well-formed
         test ctest ctest/rewrite
         
         current-contract-namespace
         make-basic-contract-namespace
         make-full-contract-namespace
         
         contract-syntax-error-test
         contract-error-test
         
         contract-eval
         contract-compile
         contract-expand-once
         
         rewrite-to-add-opt/c
         
         test-cases failures)

(define test-cases 0)
(define failures 0)

(provide new-test-case new-failure)
(define (new-test-case) (set! test-cases (+ test-cases 1)))
(define (new-failure) (set! failures (+ failures 1)))

(define (test #:test-case-name [name #f] expected fun arg1 . args)
  (new-test-case)
  ;(printf "\n\nexpected ~s\n" arg1)
  (define result
    (cond
      [(procedure? fun) (apply fun arg1 args)]
      [else arg1]))
  (unless (equal? result expected)
    (eprintf "FAILED ~a\n       got ~s\n  expected ~s\n"
            (cond
              [name name]
              [(procedure? fun) (format "~s" `(,fun ,arg1 ,@args))]
              [else (format "~s" fun)])
            result
            expected)
    (new-failure)))

(define (test-an-error name thunk sexp predicate?)
  (new-test-case)
  (define exn
    (with-handlers ((exn:fail? values))
      (thunk)
      'no-exn-raised))
  (unless (predicate? exn)
    (eprintf "FAILED ~s\n" name)
    (define msg (if (exn? exn)
                    (apply 
                     string-append
                     (exn-message exn)
                     (for/list ([x (in-list (continuation-mark-set->context 
                                             (exn-continuation-marks exn)))])
                       (format "\n  ~s" x)))
                    (format "~s" exn)))
    (display "  " (current-error-port))
    (display (regexp-replace* #rx"\n" msg "\n  ") (current-error-port))
    (newline (current-error-port))
    (new-failure)))

(define current-contract-namespace (make-parameter 'current-contract-namespace-not-initialized))

(define namespace-to-copy-from (make-base-namespace))

(define (make-basic-contract-namespace . addons)
  (define n (make-base-namespace))
  
  ;; set up just a single namespace to copy all of the 
  ;; library modules from; the top-level of the namespace
  ;; gets clobbered, but we can avoid reloading the contract
  ;; system code over and over (which is useful when there
  ;; are no .zo files compiled)
  
  (define modules-to-add (list* 'racket/contract/base
                                'racket/contract/private/blame
                                addons))
  (parameterize ([current-namespace namespace-to-copy-from])
    (for ([module-to-add (in-list modules-to-add)])
      (namespace-require module-to-add)))
  
  (for ([module-to-add (in-list modules-to-add)])
    (namespace-attach-module namespace-to-copy-from module-to-add n))
  
  (parameterize ([current-namespace n])
    (namespace-require 'racket/contract/base)
    (namespace-require '(only racket/contract/private/blame exn:fail:contract:blame?))
    (for ([addon (in-list addons)])
      (namespace-require addon)))
  n)

(define (make-full-contract-namespace . addons)
  (apply make-basic-contract-namespace 
         'racket/contract
         'racket/class
         'racket/set
         addons))

(define (contract-eval x #:test-case-name [test-case #f])
  (with-handlers ((exn:fail? (λ (x)
                               (when test-case
                                 (eprintf "exception raised while running test case ~a\n"
                                          test-case)
                                 (new-failure))
                               (raise x))))
  (parameterize ([current-namespace (current-contract-namespace)])
    (eval x))))

(define (contract-compile x)
  (parameterize ([current-namespace (current-contract-namespace)])
    (compile x)))

(define (contract-expand-once x)
  (parameterize ([current-namespace (current-contract-namespace)])
    (expand-once x)))

(define-syntax (ctest stx)
  (syntax-case stx ()
    [(_ a ...)
     (with-syntax ([line-name (format "~a:~a" 
                                      (let ([p (syntax-source stx)])
                                        (if (path? p)
                                            (let-values ([(base name dir)
                                                          (split-path p)])
                                              name)
                                            (format "~s" p)))
                                      (syntax-line stx))])
       (syntax (contract-eval #:test-case-name line-name
                              `(,test #:test-case-name line-name a ...))))]))

(define-syntax (ctest-no-error stx)
  (syntax-case stx ()
    [(_ name e)
     (syntax
      (ctest
       #t
       name
       (with-handlers ([exn:fail? (lambda (x) `(exn ,(exn-message x)))])
         e
         #t)))]))

(define (contract-error-test name exp exn-ok?)
  (test #t
        name
        (contract-eval #:test-case-name name
                       `(with-handlers ((exn:fail? (λ (x) (and (,exn-ok? x) #t)))) ,exp))))

(define (contract-syntax-error-test name exp [reg #rx""])
  (test #t
        name
        (contract-eval #:test-case-name name
                       `(with-handlers ((exn:fail:syntax?
                                         (lambda (x) (and (regexp-match ,reg (exn-message x)) #t))))
                          (eval ',exp)))))

;; test/spec-passed : symbol sexp -> void
;; tests a passing specification
(define (test/spec-passed name expression)
  (parameterize ([compile-enforce-module-constants #f])
    (contract-eval
     #:test-case-name name
     `(,test
       (void)
       (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval)
       (list ',expression '(void))))
    (let ([new-expression (rewrite-out expression)])
      (when new-expression
        (contract-eval
         #:test-case-name (format "~a rewrite-out" name)
         `(,test
           (void)
           (let ([for-each-eval (lambda (l) (for-each eval l))]) for-each-eval)
           (list ',new-expression '(void)))))))
  
  (let/ec k
    (contract-eval
     #:test-case-name (format "~a rewrite-to-add-opt/c" name)
     `(,test (void)
             (let ([for-each-eval (lambda (l) (for-each (λ (x) (eval x)) l))])
               for-each-eval)
             (list ',(rewrite-to-add-opt/c expression k) '(void))))))

(define (test/spec-passed/result name expression result)
  (parameterize ([compile-enforce-module-constants #f])
    (contract-eval #:test-case-name name `(,test #:test-case-name ',name ',result eval ',expression))
    (let/ec k
      (define opt-rewrite-name (format "~a rewrite-to-add-opt/c" name))
      (contract-eval
       #:test-case-name opt-rewrite-name
       `(,test
         #:test-case-name ,opt-rewrite-name
         ',result
         eval
         ',(rewrite-to-add-opt/c expression k))))
    (let ([new-expression (rewrite-out expression)])
      (when new-expression
        (define out-rewrite-name (format "~a rewrite-out" name))
        (contract-eval
         #:test-case-name out-rewrite-name
         `(,test
           #:test-case-name ,out-rewrite-name
           ',result
           eval
           ',new-expression))))))

;; rewrites `provide/contract' to use `contract-out'
(define (rewrite-out orig-exp)
  (define rewrote? #f)<commit_msg>adjust test/spec-passed so that tests continue when exns are raised<commit_after>#lang racket/base
(require (for-syntax racket/base))

(provide test/no-error
         test/spec-passed
         test/spec-passed/result
         test/spec-failed
         test/pos-blame
         test/neg-blame
         test/well-formed
         test ctest ctest/rewrite
         
         current-contract-namespace
         make-basic-contract-namespace
         make-full-contract-namespace
         
         contract-syntax-error-test
         contract-error-test
         
         contract-eval
         contract-compile
         contract-expand-once
         
         rewrite-to-add-opt/c
         
         test-cases failures)

(define test-cases 0)
(define failures 0)

(provide new-test-case new-failure)
(define (new-test-case) (set! test-cases (+ test-cases 1)))
(define (new-failure) (set! failures (+ failures 1)))

(define (test #:test-case-name [name #f] expected fun arg1 . args)
  (new-test-case)
  ;(printf "\n\nexpected ~s\n" arg1)
  (define result
    (cond
      [(procedure? fun) (apply fun arg1 args)]
      [else arg1]))
  (unless (equal? result expected)
    (eprintf "FAILED ~a\n       got ~s\n  expected ~s\n"
            (cond
              [name name]
              [(procedure? fun) (format "~s" `(,fun ,arg1 ,@args))]
              [else (format "~s" fun)])
            result
            expected)
    (new-failure)))

(define (test-an-error name thunk sexp predicate?)
  (new-test-case)
  (define exn
    (with-handlers ((exn:fail? values))
      (thunk)
      'no-exn-raised))
  (unless (predicate? exn)
    (eprintf "FAILED ~s\n" name)
    (define msg (if (exn? exn)
                    (apply 
                     string-append
                     (exn-message exn)
                     (for/list ([x (in-list (continuation-mark-set->context 
                                             (exn-continuation-marks exn)))])
                       (format "\n  ~s" x)))
                    (format "~s" exn)))
    (display "  " (current-error-port))
    (display (regexp-replace* #rx"\n" msg "\n  ") (current-error-port))
    (newline (current-error-port))
    (new-failure)))

(define current-contract-namespace (make-parameter 'current-contract-namespace-not-initialized))

(define namespace-to-copy-from (make-base-namespace))

(define (make-basic-contract-namespace . addons)
  (define n (make-base-namespace))
  
  ;; set up just a single namespace to copy all of the 
  ;; library modules from; the top-level of the namespace
  ;; gets clobbered, but we can avoid reloading the contract
  ;; system code over and over (which is useful when there
  ;; are no .zo files compiled)
  
  (define modules-to-add (list* 'racket/contract/base
                                'racket/contract/private/blame
                                addons))
  (parameterize ([current-namespace namespace-to-copy-from])
    (for ([module-to-add (in-list modules-to-add)])
      (namespace-require module-to-add)))
  
  (for ([module-to-add (in-list modules-to-add)])
    (namespace-attach-module namespace-to-copy-from module-to-add n))
  
  (parameterize ([current-namespace n])
    (namespace-require 'racket/contract/base)
    (namespace-require '(only racket/contract/private/blame exn:fail:contract:blame?))
    (for ([addon (in-list addons)])
      (namespace-require addon)))
  n)

(define (make-full-contract-namespace . addons)
  (apply make-basic-contract-namespace 
         'racket/contract
         'racket/class
         'racket/set
         addons))

(define (contract-eval x #:test-case-name [test-case #f])
  (with-handlers ((exn:fail? (λ (x)
                               (when test-case
                                 (eprintf "exception raised while running test case ~a\n"
                                          test-case)
                                 (new-failure))
                               (raise x))))
  (parameterize ([current-namespace (current-contract-namespace)])
    (eval x))))

(define (contract-compile x)
  (parameterize ([current-namespace (current-contract-namespace)])
    (compile x)))

(define (contract-expand-once x)
  (parameterize ([current-namespace (current-contract-namespace)])
    (expand-once x)))

(define-syntax (ctest stx)
  (syntax-case stx ()
    [(_ a ...)
     (with-syntax ([line-name (format "~a:~a" 
                                      (let ([p (syntax-source stx)])
                                        (if (path? p)
                                            (let-values ([(base name dir)
                                                          (split-path p)])
                                              name)
                                            (format "~s" p)))
                                      (syntax-line stx))])
       (syntax (contract-eval #:test-case-name line-name
                              `(,test #:test-case-name line-name a ...))))]))

(define-syntax (ctest-no-error stx)
  (syntax-case stx ()
    [(_ name e)
     (syntax
      (ctest
       #t
       name
       (with-handlers ([exn:fail? (lambda (x) `(exn ,(exn-message x)))])
         e
         #t)))]))

(define (contract-error-test name exp exn-ok?)
  (test #t
        name
        (contract-eval #:test-case-name name
                       `(with-handlers ((exn:fail? (λ (x) (and (,exn-ok? x) #t)))) ,exp))))

(define (contract-syntax-error-test name exp [reg #rx""])
  (test #t
        name
        (contract-eval #:test-case-name name
                       `(with-handlers ((exn:fail:syntax?
                                         (lambda (x) (and (regexp-match ,reg (exn-message x)) #t))))
                          (eval ',exp)))))

;; test/spec-passed : symbol sexp -> void
;; tests a passing specification
(define (test/spec-passed name expression)
  (parameterize ([compile-enforce-module-constants #f])
    (contract-eval
     #:test-case-name name
     `(,test
       #:test-case-name ',name
       'no-exn-raised
       eval
       '(with-handlers ([exn:fail? exn-message])
          ,expression
          'no-exn-raised)))
    (let ([new-expression (rewrite-out expression)])
      (when new-expression
        (contract-eval
         #:test-case-name (format "~a rewrite-out" name)
         `(,test
           #:test-case-name ,(format "~a rewrite-out" name)
           'no-exn-raised
           eval
           '(with-handlers ([exn:fail? exn-message])
              ,new-expression
              'no-exn-raised))))))
  
  (let/ec k
    (contract-eval
     #:test-case-name (format "~a rewrite-to-add-opt/c" name)
     `(,test #:test-case-name ,(format "~a rewrite-to-add-opt/c" name)
             'no-exn-raised
             eval
             '(with-handlers ([exn:fail? exn-message])
                ,(rewrite-to-add-opt/c expression k)
                'no-exn-raised)))))

(define (test/spec-passed/result name expression result)
  (parameterize ([compile-enforce-module-constants #f])
    (contract-eval #:test-case-name name `(,test #:test-case-name ',name ',result eval ',expression))
    (let/ec k
      (define opt-rewrite-name (format "~a rewrite-to-add-opt/c" name))
      (contract-eval
       #:test-case-name opt-rewrite-name
       `(,test
         #:test-case-name ,opt-rewrite-name
         ',result
         eval
         ',(rewrite-to-add-opt/c expression k))))
    (let ([new-expression (rewrite-out expression)])
      (when new-expression
        (define out-rewrite-name (format "~a rewrite-out" name))
        (contract-eval
         #:test-case-name out-rewrite-name
         `(,test
           #:test-case-name ,out-rewrite-name
           ',result
           eval
           ',new-expression))))))

;; rewrites `provide/contract' to use `contract-out'
(define (rewrite-out orig-exp)
  (define rewrote? #f)
{'fraction_non_alphanumeric': 0.14285714285714285, 'fraction_numerical': 0.0011661807580174927, 'mean_word_length': 1.7852760736196318, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 7, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 42, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7487115', 'n_tokens_mistral': 4852, 'n_tokens_neox': 4629, 'n_words': 1112}