<commit_before>(declare (usual-integrations))

(define-syntax case*
  (er-macro-transformer
   (lambda (form rename compare)
     (let ((expr (cadr form))
           (expr-name (generate-uninterned-symbol 'expr-)))
       (define (arrow-form? clause)
         (and (= 3 (length clause))
              (compare (rename '=>) (cadr clause))))
       (define (ignore? thing)
         (compare thing (rename '_)))
       (define-integrable (as-pattern pattern win lose)
         (let loop ((pattern pattern) (skipped '()))
           (cond ((not (pair? pattern)) (lose))
                 ((null? (cdr pattern)) (lose))
                 ((and (null? (cddr pattern))
                       (symbol? (car pattern))
                       (compare (car pattern) (rename ':as)))
                  (win (reverse skipped) (cadr pattern)))
                 (else (loop (cdr pattern) (cons (car pattern) skipped))))))
       (define (parse-clause clause lose-name)
         (define (arrow-clause matcher procedure)
           `(,matcher ,expr-name ,procedure ,lose-name))
         (define (standard-clause expr-name pattern body)
           (define (standard-pattern expr-name pattern body)
             (receive (variables body)
               (let loop ((subpatterns (cdr pattern)))
                 (cond ((null? subpatterns) (values '() body))
                       ((pair? (car subpatterns))
                        (receive (true-subpattern variable)
                          (as-pattern (car subpatterns)
                           values
                           (lambda ()
                             (values (car subpatterns)
                                     (generate-uninterned-symbol 'part-))))
                          (receive (variables body) (loop (cdr subpatterns))
                            (values (cons variable variables)
                                    (list (standard-pattern variable true-subpattern body))))))
                       ;; Assume identifier
                       ((ignore? (car subpatterns))
                        (let ((variable (generate-uninterned-symbol 'dead-)))
                          (receive (variables body) (loop (cdr subpatterns))
                            (values (cons variable variables)
                                    (cons `(declare (ignore ,variable))
                                          body)))))
                       (else ;; Assume identifier
                        (receive (variables body) (loop (cdr subpatterns))
                          (values (cons (car subpatterns) variables)
                                  body)))))
               `(,(car pattern) ,expr-name (,(rename 'lambda) ,variables ,@body) ,lose-name)))
           (cond ((pair? pattern)
                  (as-pattern pattern
                   (lambda (true-pattern variable)
                     `(let ((,variable ,expr-name))
                        ,(standard-pattern expr-name true-pattern body)))
                   (lambda ()
                     (standard-pattern expr-name pattern body))))
                 ((ignore? pattern)
                  `(let ()
                     (declare (ignore ,lose-name))
                     ,@body))
                 (else
                  `(let ((,pattern ,expr-name))
                     (declare (ignore ,lose-name))
                     ,@body))))
         (if (arrow-form? clause)
             (arrow-clause (car clause) (caddr clause))
             (standard-clause expr-name (car clause) (cdr clause))))
       `(,(rename 'let) ((,expr-name ,expr))
          ,(let loop ((clauses (cddr form)))
             (if (null? clauses)
                 (rename 'unspecific)
                 (let ((lose-name (generate-uninterned-symbol 'lose-)))
                   `(,(rename 'let) ((,lose-name (,(rename 'lambda) () ,(loop (cdr clauses)))))
                     ,(parse-clause (car clauses) lose-name))))))))))

(define-syntax define-algebraic-matcher
  (syntax-rules ()
    ((_ matcher predicate accessor ...)
     (define-integrable (matcher thing win lose)
       (if (predicate thing)
           (win (accessor thing) ...)
           (lose))))))

(define-algebraic-matcher pair pair? car cdr)
(define-algebraic-matcher null null?)
(define-algebraic-matcher boolean boolean?)
(define-algebraic-matcher number number?)


(define (test-it thing count)
  (show-time
   (lambda ()
     (let loop ((count count))
       (if (= count 0)
           'ok
           (begin
             (my-do-it2 thing)
             (loop (- count 1))))))))

;; TODO good error messages if syntax is wrong; define all needed matchers<commit_msg>Don't need that any more.<commit_after>(declare (usual-integrations))

(define-syntax case*
  (er-macro-transformer
   (lambda (form rename compare)
     (let ((expr (cadr form))
           (expr-name (generate-uninterned-symbol 'expr-)))
       (define (arrow-form? clause)
         (and (= 3 (length clause))
              (compare (rename '=>) (cadr clause))))
       (define (ignore? thing)
         (compare thing (rename '_)))
       (define-integrable (as-pattern pattern win lose)
         (let loop ((pattern pattern) (skipped '()))
           (cond ((not (pair? pattern)) (lose))
                 ((null? (cdr pattern)) (lose))
                 ((and (null? (cddr pattern))
                       (symbol? (car pattern))
                       (compare (car pattern) (rename ':as)))
                  (win (reverse skipped) (cadr pattern)))
                 (else (loop (cdr pattern) (cons (car pattern) skipped))))))
       (define (parse-clause clause lose-name)
         (define (arrow-clause matcher procedure)
           `(,matcher ,expr-name ,procedure ,lose-name))
         (define (standard-clause expr-name pattern body)
           (define (standard-pattern expr-name pattern body)
             (receive (variables body)
               (let loop ((subpatterns (cdr pattern)))
                 (cond ((null? subpatterns) (values '() body))
                       ((pair? (car subpatterns))
                        (receive (true-subpattern variable)
                          (as-pattern (car subpatterns)
                           values
                           (lambda ()
                             (values (car subpatterns)
                                     (generate-uninterned-symbol 'part-))))
                          (receive (variables body) (loop (cdr subpatterns))
                            (values (cons variable variables)
                                    (list (standard-pattern variable true-subpattern body))))))
                       ;; Assume identifier
                       ((ignore? (car subpatterns))
                        (let ((variable (generate-uninterned-symbol 'dead-)))
                          (receive (variables body) (loop (cdr subpatterns))
                            (values (cons variable variables)
                                    (cons `(declare (ignore ,variable))
                                          body)))))
                       (else ;; Assume identifier
                        (receive (variables body) (loop (cdr subpatterns))
                          (values (cons (car subpatterns) variables)
                                  body)))))
               `(,(car pattern) ,expr-name (,(rename 'lambda) ,variables ,@body) ,lose-name)))
           (cond ((pair? pattern)
                  (as-pattern pattern
                   (lambda (true-pattern variable)
                     `(let ((,variable ,expr-name))
                        ,(standard-pattern expr-name true-pattern body)))
                   (lambda ()
                     (standard-pattern expr-name pattern body))))
                 ((ignore? pattern)
                  `(let ()
                     (declare (ignore ,lose-name))
                     ,@body))
                 (else
                  `(let ((,pattern ,expr-name))
                     (declare (ignore ,lose-name))
                     ,@body))))
         (if (arrow-form? clause)
             (arrow-clause (car clause) (caddr clause))
             (standard-clause expr-name (car clause) (cdr clause))))
       `(,(rename 'let) ((,expr-name ,expr))
          ,(let loop ((clauses (cddr form)))
             (if (null? clauses)
                 (rename 'unspecific)
                 (let ((lose-name (generate-uninterned-symbol 'lose-)))
                   `(,(rename 'let) ((,lose-name (,(rename 'lambda) () ,(loop (cdr clauses)))))
                     ,(parse-clause (car clauses) lose-name))))))))))

(define-syntax define-algebraic-matcher
  (syntax-rules ()
    ((_ matcher predicate accessor ...)
     (define-integrable (matcher thing win lose)
       (if (predicate thing)
           (win (accessor thing) ...)
           (lose))))))

(define-algebraic-matcher pair pair? car cdr)
(define-algebraic-matcher null null?)
(define-algebraic-matcher boolean boolean?)
(define-algebraic-matcher number number?)

;; TODO good error messages if syntax is wrong; define all needed matchers
{'fraction_non_alphanumeric': 0.12800088505365637, 'fraction_numerical': 0.0005531585352361987, 'mean_word_length': 1.4692706910680142, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 5, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 12, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3690009', 'n_tokens_mistral': 2354, 'n_tokens_neox': 2234, 'n_words': 649}