;;; 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 occurrences
;       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 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,
;     (cute cons (+ a 1) <>) is the same as (let ((a1 (+ a 1))) (lambda (x2) (cons a1 x2)))
; As you see from comparing this example with the first example above, the
; cute-variant will evaluate (+ a 1) once, while the cut-variant will evaluate
; it during every invokation of the resulting procedure.
  
(define-syntax (cute stx)
  (syntax-case stx (<> <...>)
    [(cute)
     (raise-syntax-error #f "cute expects 1 or more slots or expressions, given none"  stx)]
    [(cute <>)
     #'(lambda (f) (f))]
    [(cute <...> slot-or-expr ...)
     (raise-syntax-error #f "cute expects an expression at the first position, given <...>" stx)]
    [(cute proc)
     #'(lambda () (proc))]
    [(cute <> slot-or-expr ... <...>)
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names ignored names bindings)
                             #`(let #,bindings
                                 (lambda (f #,@slot-names . xs)
                                   (apply f #,@names xs)))))]
    [(cute <> slot-or-expr ...)
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names ignored names bindings)
                             #`(let #,bindings
                                 (lambda (f #,@slot-names)
                                   (f #,@names)))))]
    [(cute proc slot-or-expr ... <...>)
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names ignored names bindings)
                             #`(let #,bindings
                                 (lambda (#,@slot-names . xs)
                                   (apply proc #,@names xs)))))]
    [(cute proc slot-or-expr ...)
     (generate-names/exprs #'(slot-or-expr ...)
                           (lambda (slot-names ignored names bindings)
                             #`(let #,bindings
                                 (lambda #,slot-names
                                   (proc #,@names)))))]))