Re: question on the opaque syntax object debate

[Jens Axel Søgaard <jensaxel@xxxxxxxxxxxx>]

Andre van Tonder wrote:
> On Thu, 18 Aug 2005, Andrew Wilcox wrote:

> > Thus my question is: does PLT Scheme have syntax location features
> > that this SRFI proposal is not able to provide?

> There is one that it would in principle be able to provide but chooses 
> not to: The SRFI proposal requires the first argument of 
> datum->syntax-object to be an identifier, as indeed Chez does, while PLT 
> allows an arbitrary syntax object there.
>
> There is no fundamental reason why this cannot be supported, but it 
> would make the reference implementation more complex.  Also, I don't 
> know how useful this feature really is in practice.

Attached below is an example, in which I used it. The function 
substitute-<>-with-name makes a recursive decent on a syntax-object
and replaces <> with fresh names. Quasisyntax/loc (which is
implemented using datum->syntax-object) is used to keep the
properties of the original syntax.

/Jens Axel

;;; deep-cut.ss  --  Jens Axel Soegaard

; This file implementes a generalized version of cut from srfi-26.

;  The macro cut transforms a <cut-expression> into a <lambda expression> 
;  with as many formal variables as there are slots in the list <slot-or-expr>*. 
;  The body of the resulting <lambda expression> calls the first <slot-or-expr> 
;  with arguments from <slot-or-expr>* in the order they appear. In case there 
;  is a rest-slot symbol, the resulting procedure is also of variable arity, 
;  and the body calls the first <slot-or-expr> with all arguments provided to 
;  the actual call of the specialized procedure.

; <cut-expression> -->  (cut <slot-or-expr> <slot-or-expr>*) 
;                   |   (cut <slot-or-expr> <slot-or-expr>* <...>) ; with "rest-slot" 
;                   |   (cute <slot-or-expr> <slot-or-expr>*) ; evaluate non-slots at specialization time 
;                   |   (cute <slot-or-expr> <slot-or-expr>* <...>) ; with "rest-slot" 

; <slot-or-expr>   -->  <>; a "slot" 
;                   |   <expression>; a "non-slot expression" 

(module cut mzscheme
  
  (provide cut)
  
  (define-for-syntax (fresh-name)
    (car (generate-temporaries #'(cut))))
  
  (define-for-syntax (substitute-<>-with-name expr)
    (syntax-case expr (<>)
      [<>       (let ((name (fresh-name)))
                  (values (list name) name))]
      [(a . d)  (let-values ([(a-names a-expr) (substitute-<>-with-name #'a)]
                             [(d-names d-expr) (substitute-<>-with-name #'d)])
                  (values (append a-names d-names)
                          (quasisyntax/loc expr
                            (#,a-expr . #,d-expr))))]
      [_        (values '() expr)]))
  
  
  ; generate-names/exprs : 
  ;    Given the arguments for the macro call to cut as a syntax-list,
  ;  call build with two 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.
  (define-for-syntax (generate-names/exprs slot-or-exprs build)
    (let loop ([slot-or-exprs   (syntax->list slot-or-exprs)]
               [slot-names      '()]
               [names-or-exprs  '()])
      (cond
        [(null? slot-or-exprs)  (build (reverse slot-names)
                                       (reverse names-or-exprs))]
        [else                   (let-values ([(names substituted-expr)
                                              (substitute-<>-with-name (car slot-or-exprs))])
                                  (loop (cdr slot-or-exprs)
                                        (append (reverse names) slot-names)
                                        (cons substituted-expr names-or-exprs)))])))
  
  (require-for-syntax (lib "name.ss" "syntax"))
  
  (define-for-syntax (make-inferred-cut-name stx)
    (cond
      [(identifier? stx)                       (string->symbol
                                                (string-append
                                                 "specialized version of "
                                                 (symbol->string (syntax-e stx))
                                                 " originating from a cut"))]
      [(syntax-property stx 'inferred-name) => (lambda (name)
                                                 (string->symbol
                                                  (string-append
                                                   "specialized version of "
                                                   (symbol->string name)
                                                   " originating from a cut")))]
      [else                                     #f]))
  
  (define-for-syntax (set-inferred-name stx name)
    (if name
        (syntax-property stx 'inferred-name name)
        stx))
  
  (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)
       (set-inferred-name 
        #`(lambda () #,(syntax/loc stx (proc)))
        (make-inferred-cut-name #'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 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)))))]))
  
  )

;(require cut)
;> ((cut list '- (list <> (list '- <> <> '-)) (list <>) (list <> (list <> <>))) 2 3 4 5 6 7 8)
;(- (2 (- 3 4 -)) (5) (6 (7 8)))