Fixed the nested ‘from x in y’ problem

Thanks to Jos, Aziz and Andre for tips on comp.lang.scheme.

(import (rnrs))

(define (compare asc? a b)
  (cond
    [(and (number? a) (number? b))
      ((if asc? < >) a b)]
    [(and (char? a) (char? b))
      ((if asc? char<? char>?) a b)]
    [(and (string? a) (string? b))
      ((if asc? string<? string>?) a b)]
    [(and (symbol? a) (symbol? b))
        (let ((a (symbol->string a))
              (b (symbol->string b)))
           ((if asc? string<? string>?) a b))]
    [else
      (assertion-violation 'compare "not supported" a b)]))

(define (sort asc? l a b)
  (list-sort
    (lambda (a* b*)
      (compare asc? (a a*) (b b*)))
    l))

(define (flatten lists)
  (apply append lists))

(define-syntax from
  (lambda (x)
    (letrec
      ((vars ‘())
       (id=?
          (lambda (e o)
            (eq? (syntax->datum e) o)))
       (arg
          (lambda (e)
            (if (= 1 (length vars))
              (datum->syntax e `(list ,(syntax->datum e)))
              e)))
       (init
          (lambda (e)
            (when (null? vars)
              (set! vars (list e)))))
       (valid-id?
          (lambda (e)
            (and (identifier? e)
              (not (memp
                     (lambda (x)
                       (bound-identifier=? e x))
                     vars)))))
       (from*
          (lambda (x)
            (syntax-case x (in select)
              [(e in l select s)
                (identifier? #'e)
                (begin
                  (init #'e) ; bind
                   #`(map
                      (lambda (K)
                        (apply
                          (lambda (#,@vars) s)
                          #,(arg #'K)))
                      l))]
              [(e in l c ... select s)
                (identifier? #'e)
                (begin
                  (init #'e) ; bind
                  (syntax-case #'(c ...) (where let = in orderby)
                    [(where p rest ...)
                      (from* #`(e in
                          (filter
                            (lambda (K)
                              (apply
                                (lambda (#,@vars) p)
                                #,(arg #'K)))
                            l)
                         rest ...
                         select s))]
                    [(let y = y* rest ...)
                      (valid-id? #'y)
                      (let ((v* vars)
                            (a* (arg #'K)))
                        (set! vars (cons #'y vars))
                        (from* #`(e in
                            (map
                              (lambda (K)
                                (apply
                                  (lambda (#,@v*)
                                    (list y* #,@v*))
                                  #,a*))
                              l)
                           rest ...
                           select s)))]
                    [(from e* in l* rest ...)
                      (valid-id? #'e*)
                      (let ((v* vars)
                            (a* (arg #'K)))
                        (set! vars (cons #'e* vars))
                        (from* #`(e in
                              (flatten
                                (map
                                  (lambda (K)
                                    (apply
                                      (lambda (#,@v*)
                                        (map
                                          (lambda (K*)
                                            (list K* #,@v*))
                                        l*))
                                      #,a*))
                                  l))
                           rest ...
                           select s)))]
                    [(orderby p dir rest ...)
                      (or (id=? #'dir 'asc) (id=? #'dir 'desc))
                      (from* #`(e in
                          (let ((p*
                            (lambda (K)
                              (apply
                                (lambda (#,@vars) p)
                                #,(arg #'K)))))
                            (sort #,(id=? #'dir 'asc) l p* p*))
                         rest ...
                         select s))]
                    [(orderby p rest ...)
                      (from* #'(e in l
                         orderby p asc
                         rest ...
                         select s))]
                ))]))))
         (syntax-case x ()
            [(from . rest)
              (from* #'rest)]))))

Example:

(define args (list (string->list “hello”) (string->list “world”)))

(display
  [
    from K in args
    from K* in K
    where (not (char=? #\l K*))
    orderby K*
    select K*
  ])
(newline) ;=> (d e h o o r w)

Your response: