<commit_before>;;; cut.ss

; This file reimplements srfi-26 for PLT.
; The reimplementation provides better error messages.

; Examples of errors with better error messages:
;   (cut)
;   ((cut cons <> <>) 1 2 3)

#lang scheme/base
  
(provide cut cute)
  
; generate-names/exprs :
;    Given the arguments for the macro call to cut (or cute) as a syntax-list,
;  call build with four lists:
;    1) a list of names given to each <>-slot
;    2) [cut] a list of the macro arguments, except that all occurences
;       of a <>-slots have been substituted with the chosen name.
;    3) [cute] a list the names given to the exprs and the <>-slots
;    4) [cute] a list of lists of name-expression pairs, i.e. the bindings
;       used to bind the expressions to names, in order to evaluate
;       the expressions at the time of the macro call to cute.
(define-for-syntax (generate-names/exprs slot-or-exprs build)
  (let loop ([slot-or-exprs       (syntax->list slot-or-exprs)]
             [slot-names          '()]
             [cut-names-or-exprs  '()]
             [cute-names          '()]
             [bindings            '()])
    (cond
     [(null? slot-or-exprs)  (build (reverse slot-names)
                                    (reverse cut-names-or-exprs)
                                    (reverse cute-names)
                                    (reverse bindings))]
     [else                   (let ((name (car (generate-temporaries #'(x)))))
                               (syntax-case (car slot-or-exprs) (<> <...>)
                                 [<>
                                  (loop (cdr slot-or-exprs)
                                        (cons name slot-names)
                                        (cons name cut-names-or-exprs)
                                        (cons name cute-names)
                                        bindings)]
                                 [_
                                  (loop (cdr slot-or-exprs)
                                        slot-names
                                        (cons (car slot-or-exprs) cut-names-or-exprs)
                                        (cons name cute-names)
                                        (cons (list name (car slot-or-exprs))
                                              bindings))]))])))
  
(define-syntax (cut stx)
  (syntax-case stx (<> <...>)
    [(cut)
     (raise-syntax-error #f "cut expects 1 or more slots or expressions, given none"  stx)]
    [(cut <>)
     #'(lambda (f) (f))]
    [(cut <...> slot-or-expr ...)
     (raise-syntax-error #f "cut expects a a slot or an expression at the first position, given <...>" stx)]
    [(cut proc)
     #'(lambda () (proc))]
    [(cut <> slot-or-expr ... <...>)
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names names-or-exprs . ignored)
                             #`(lambda (f . xs)
                                 #,(quasisyntax/loc stx
                                                    (apply f #,@names-or-exprs xs)))))]
    [(cut <> slot-or-expr ...)
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names names-or-exprs . ignored)
                             #`(lambda (x #,@slot-names)
                                 (x #,@(datum->syntax-object stx names-or-exprs)))))]
    [(cut proc slot-or-expr ... <...>)
     ;;   Applying a wrong number of arguments to the the lamba generated by cut, will provoke an
     ;; error caused by the application (proc ...). The quasisyntax/loc makes sure DrScheme
     ;; shows the cut-expression as the source of the error in stead of the showing an error in
     ;; the code implementing the macro i.e. in this code.
     ;;   Note: Is it possible to propagate the error to the location of the wrong application
     ;;         in the user code?
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names names-or-exprs . ignored)
                             #`(lambda (#,@slot-names . xs)
                                 #,(quasisyntax/loc stx
                                                    (apply proc #,@names-or-exprs xs)))))]
    [(cut proc slot-or-expr ...)
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names names-or-exprs . ignored)
                             #`(lambda #,slot-names
                                 #,(quasisyntax/loc stx
                                                    (proc #,@names-or-exprs)))))]))
  
;  In addition to cut, there is a variant called cute (a mnemonic for
; "cut with evaluated non-slots") which evaluates the non-slot expressions
; at the time the procedure is specialized, not at the time the specialized
; procedure is called. For example,<commit_msg>Updated to use datum->syntax.<commit_after>;;; cut.ss

; This file reimplements srfi-26 for PLT.
; The reimplementation provides better error messages.

; Examples of errors with better error messages:
;   (cut)
;   ((cut cons <> <>) 1 2 3)

#lang scheme/base
  
(provide cut cute)
(require (for-syntax scheme/base))
  
; generate-names/exprs :
;    Given the arguments for the macro call to cut (or cute) as a syntax-list,
;  call build with four lists:
;    1) a list of names given to each <>-slot
;    2) [cut] a list of the macro arguments, except that all occurences
;       of a <>-slots have been substituted with the chosen name.
;    3) [cute] a list the names given to the exprs and the <>-slots
;    4) [cute] a list of lists of name-expression pairs, i.e. the bindings
;       used to bind the expressions to names, in order to evaluate
;       the expressions at the time of the macro call to cute.
(define-for-syntax (generate-names/exprs slot-or-exprs build)
  (let loop ([slot-or-exprs       (syntax->list slot-or-exprs)]
             [slot-names          '()]
             [cut-names-or-exprs  '()]
             [cute-names          '()]
             [bindings            '()])
    (cond
     [(null? slot-or-exprs)  (build (reverse slot-names)
                                    (reverse cut-names-or-exprs)
                                    (reverse cute-names)
                                    (reverse bindings))]
     [else                   (let ((name (car (generate-temporaries #'(x)))))
                               (syntax-case (car slot-or-exprs) (<> <...>)
                                 [<>
                                  (loop (cdr slot-or-exprs)
                                        (cons name slot-names)
                                        (cons name cut-names-or-exprs)
                                        (cons name cute-names)
                                        bindings)]
                                 [_
                                  (loop (cdr slot-or-exprs)
                                        slot-names
                                        (cons (car slot-or-exprs) cut-names-or-exprs)
                                        (cons name cute-names)
                                        (cons (list name (car slot-or-exprs))
                                              bindings))]))])))
  
(define-syntax (cut stx)
  (syntax-case stx (<> <...>)
    [(cut)
     (raise-syntax-error #f "cut expects 1 or more slots or expressions, given none"  stx)]
    [(cut <>)
     #'(lambda (f) (f))]
    [(cut <...> slot-or-expr ...)
     (raise-syntax-error #f "cut expects a a slot or an expression at the first position, given <...>" stx)]
    [(cut proc)
     #'(lambda () (proc))]
    [(cut <> slot-or-expr ... <...>)
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names names-or-exprs . ignored)
                             #`(lambda (f . xs)
                                 #,(quasisyntax/loc stx
                                                    (apply f #,@names-or-exprs xs)))))]
    [(cut <> slot-or-expr ...)
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names names-or-exprs . ignored)
                             #`(lambda (x #,@slot-names)
                                 (x #,@(datum->syntax stx names-or-exprs)))))]
    [(cut proc slot-or-expr ... <...>)
     ;;   Applying a wrong number of arguments to the the lamba generated by cut, will provoke an
     ;; error caused by the application (proc ...). The quasisyntax/loc makes sure DrScheme
     ;; shows the cut-expression as the source of the error in stead of the showing an error in
     ;; the code implementing the macro i.e. in this code.
     ;;   Note: Is it possible to propagate the error to the location of the wrong application
     ;;         in the user code?
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names names-or-exprs . ignored)
                             #`(lambda (#,@slot-names . xs)
                                 #,(quasisyntax/loc stx
                                                    (apply proc #,@names-or-exprs xs)))))]
    [(cut proc slot-or-expr ...)
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names names-or-exprs . ignored)
                             #`(lambda #,slot-names
                                 #,(quasisyntax/loc stx
                                                    (proc #,@names-or-exprs)))))]))
  
;  In addition to cut, there is a variant called cute (a mnemonic for
; "cut with evaluated non-slots") which evaluates the non-slot expressions
; at the time the procedure is specialized, not at the time the specialized
; procedure is called. For example,
{'fraction_non_alphanumeric': 0.11893907998342312, 'fraction_numerical': 0.0020721094073767096, 'mean_word_length': 1.2863571766935102, 'pattern_counts': {'":': 0, '<': 37, '<?xml version=': 0, '>': 42, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 52, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '319688', 'n_tokens_mistral': 2628, 'n_tokens_neox': 2501, 'n_words': 837}