[plt-scheme] Fun with paren-shape

Hi all,

Here's a fun little hack. It provides concise
syntax for integer ranges and vector references.

  [a .. b]  => (interval a b)
  (... expr1 [expr2] ...) => (... (vector-ref expr1 expr2) ...)


Example:

 > (require index)

 > (define (sum xs) (apply + xs))

 > [1 .. 11]
(1 2 3 4 5 6 7 8 9 10)

 > (sum [1 .. 11])
55


 > (define v (vector 'a 'b 'c))
 > (list v[0] v[1] v[2])
(a b c)

 > (+ (vector 1 2)[0] 3)
4


 > (define (len o)
     (cond
       [(pair? o)   (length o)]
       [(vector? o) (vector-length o)]
       [(string? o) (string-length o)]
       [(bytes? o)  (bytes-length o)]
       [else        (error 'len "I give up" o)]))

 > (define v1 (vector 1 0 1))
 > (define v2 (vector 2 3 4))

 > (define (dot-product v1 v2)
     (sum (map (λ (i) (* v1[i] v2[i]))
               [0 .. (len v1)])))
6


(module index mzscheme
   (provide (rename my-app #%app))
   (require-for-syntax (lib "stx.ss" "syntax"))

   (define (interval n m)
     (cond
       [(>= n m) '()]
       [(< n m) (cons n (interval (+ n 1) m))]))

   (define-syntax (my-app stx)
     (define (bracket-shaped? stx)
       (equal? (syntax-property stx 'paren-shape) #\[))
     (define (brackets? parens)
       (syntax-case parens ()
         [(x) (bracket-shaped? parens)]
         [_ #f]))
     (define (range? stx)
       (syntax-case* stx (..) module-or-top-identifier=?
         [(a .. b) (bracket-shaped? stx)]
         [_        #f]))
     (define (handle-brackets exprs)
       ; vector brackets
       (let loop ([exprs      exprs]
                  [prev-exprs '()])
         (cond
           [(null? exprs)
            (reverse prev-exprs)]
           [(null? (cdr exprs))
            (loop (cdr exprs) (cons (car exprs) prev-exprs))]
           [(not (brackets? (cadr exprs)))
            (loop (cdr exprs) (cons (car exprs) prev-exprs))]
           [else
            (loop (cddr exprs)
                  (cons (quasisyntax/loc (cadr exprs)
                          (vector-ref #,(car exprs) #,@(cadr exprs)))
                        prev-exprs))])))
     (define (handle-ranges exprs)
       (let loop ([exprs      exprs]
                  [prev-exprs '()])
         (cond
           [(null? exprs)
            (reverse prev-exprs)]
           [(not (range? (car exprs)))
            (loop (cdr exprs) (cons (car exprs) prev-exprs))]
           [else
            (with-syntax ([[from .. to] (car exprs)])
              (loop (cdr exprs)
                    (cons (syntax/loc (car exprs)
                            (interval from to))
                          prev-exprs)))])))
     (syntax-case* stx (..) module-or-top-identifier=?
       [(_ a .. b)
        (bracket-shaped? stx)
        (quasisyntax/loc stx
          (interval a b))]
       [(_ expr . more )
        (or (ormap brackets? (cddr (syntax->list stx)))
            (ormap range?    (cdr (syntax->list stx))))
        (with-syntax ([(expr ...)
                       (handle-ranges
                        (handle-brackets
                         (cdr (syntax->list stx))))])
          (quasisyntax/loc stx
            (#%app expr ...)))]
       [(_ . more)
        (syntax/loc stx
          (#%app . more))])))

(require index)

(define (sum xs)
   (apply + xs))

[1 .. 11]
(sum [1 .. 11])


(define v (vector 'a 'b 'c))
(list v[0] v[1] v[2])

(define (len o)
   (cond
     [(pair? o)   (length o)]
     [(vector? o) (vector-length o)]
     [(string? o) (string-length o)]
     [(bytes? o)  (bytes-length o)]
     [else        (error 'len "I give up" o)]))

(define v1 (vector 1 0 1))
(define v2 (vector 2 3 4))

(define (dot-product v1 v2)
   (sum (map (λ (i) (* v1[i] v2[i]))
             [0 .. (len v1)])))



-- 
Jens Axel Søgaard