Posted by: leppie | April 20, 2008

LINQ for R6RS Scheme take 9

Now completely rewritten. Supports all the non-grouping constructs for now. From what I can see, this is quite similar to the LISP FOR construct.

Tested on IronScheme, Ikarus and Petite Chez.

(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 lst)
  (apply append lst))

(define-syntax bind
  (syntax-rules ()
    [(bind var body)
      (lambda (var) body)]
    [(bind vars ... body)
      (lambda (K)
        (apply
          (lambda (vars ...) body)
          K))]))

(define-syntax from
  (lambda (x)
    (define valid-id?
      (lambda (e vars)
         (and (identifier? e)
           (not (memp
                  (lambda (x)
                    (bound-identifier=? e x))
                  vars)))))
    (define id=?
      (lambda (e o)
        (eq? (syntax->datum e) o)))
    (syntax-case x (in)
      [(_ e in l rest ...)
        (identifier? #'e)
        (let recur ((vars (list #'e))
                    (l #'l)
                    (x* #'(rest ...)))
          (syntax-case x* (where let = in select from orderby join equals on)
            [() (syntax-violation 'from "missing select" x)]
            [(select s)
              #`(map (bind #,@vars s) #,l)]
            [(where p rest ...)
              (recur vars
                #`(filter (bind #,@vars p) #,l)
                #'(rest ...))]
            [(from e* in l* rest ...)
              (if (valid-id? #'e* vars)
                (recur (cons #'e* vars)
                  #`(flatten
                      (map
                        (bind #,@vars
                          (map
                            (lambda (K*)
                              (list K* #,@vars))
                            l*))
                        #,l))
                   #'(rest ...))
                (syntax-violation 'from "not a unique identifier" #'e* x*))]
            [(let a = b rest ...)
              (if (valid-id? #'a vars)
                (recur (cons #'a vars)
                  #`(map (bind #,@vars (list b #,@vars)) #,l)
                  #'(rest ...))
                (syntax-violation 'from "not a unique identifier" #'a x*))]
            [(orderby p dir rest ...)
              (or (id=? #'dir 'asc) (id=? #'dir 'desc))
              (recur vars
                #`(let* ((p*
                    (bind #,@vars p)))
                    (sort #,(id=? #'dir 'asc) #,l p* p*))
                #'(rest ...))]
            [(orderby p rest ...)
              (recur vars l #'(orderby p asc rest ...))]
            [(join e* in l* on a equals b rest ...)
              (recur vars l
                #'(from e* in l* where (eqv? a b) rest ...))]
            ))])))
Advertisements

Leave a Reply

Please log in using one of these methods to post your comment:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Categories

%d bloggers like this: