;;; cut.ss  --  Jens Axel Soegaard

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

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

(module cut mzscheme
  
  (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 <>)
       (raise-syntax-error #f "cut expects an expression at the first position, given a slot <>" stx)]
      [(cut proc)
       #'(lambda () (proc))]
      [(cut <> slot-or-expr ...)
       (raise-syntax-error #f "cut expects an expression at the first position, given a slot <>" stx)]
      [(cut <...> slot-or-expr ...)
       (raise-syntax-error #f "cut expects an expression at the first position, given <...>" stx)]
      [(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,
  ;     (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 <>)
       (raise-syntax-error #f "cute expects an expression at the first position, given a slot <>" stx)]
      [(cute proc)
       #'(lambda () (proc))]
      [(cute <> slot-or-expr ...)
       (raise-syntax-error #f "cute expects an expression at the first position, given a slot <>" stx)]
      [(cute <...> slot-or-expr ...)
       (raise-syntax-error #f "cute expects an expression at the first position, given <...>" stx)]
      [(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)))))]))
  )

