;;; Version: 0.1
;;; Author: Michele Simionato
;;; Email: michele.simionato@gmail.com
;;; Date: 29-Oct-2008

(declare (export))
(use syntax-case)

;; compatibility function
(define-for-syntax (fold-right kons knil lis1)
  (let recur ((lis lis1))
    (if (null? lis) knil
        (let ((head (car lis)))
          (kons head (recur (cdr lis)))))))

;; helper macro
(define-syntax guarded-syntax-case
  (let ((add-clause
         (lambda (clause acc)
           (syntax-case clause ()
             ((pattern skeleton . rest)
                (syntax-case (syntax rest) ()
                  ((cond? else1 else2 ...)
                   (cons*
                    (syntax (pattern cond? skeleton))
                    (syntax (pattern (begin else1 else2 ...)))
                    acc))
                  ((cond?)
                   (cons (syntax (pattern cond? skeleton)) acc))
                  (()
                   (cons (syntax (pattern skeleton)) acc))
                  ))))))
    (lambda (x)
      (syntax-case x ()
        ((guarded-syntax-case y (literal ...) clause ...)
         (with-syntax
             (((c ...) (fold-right add-clause '() (syntax (clause ...)))))
           (syntax (syntax-case y (literal ...) c ...))))))))

(define-syntax syntax-match
  (lambda (x)
   (syntax-case x (sub)
    ((_ (literal ...) (sub patt skel . rest) ...)
     (syntax (lambda (x)
       (syntax-match x (literal ...)
         (sub patt skel . rest) ...))))
    ((_ x (literal ...) (sub patt skel . rest) ...)
     (and (identifier? (syntax x)) (andmap identifier? (syntax (literal ...))))
     (syntax (guarded-syntax-case x
       (<literals> <patterns> <source> <transformer> literal ...)
       ((ctx <literals>)
        (syntax '((... (... literal)) ...)))
       ((ctx <patterns>)
        (syntax '((... (... patt)) ...)))
       ((ctx <source>)
        (syntax '(syntax-match (literal ...)
              (... (... (sub patt skel . rest))) ...)))
       ((ctx <transformer>)
        (syntax (syntax-match (literal ...)
              (... (... (sub patt skel . rest))) ...)))
       (patt skel . rest) ...)))
    )))

(define-syntax def-syntax
  (syntax-match ()
    (sub (def-syntax (name . args) skel . rest)
     (syntax (define-syntax name
               (syntax-match () (sub (name . args) skel . rest)))))
    (sub (def-syntax name transformer)
     (syntax (define-syntax name transformer)))
    ))

(def-syntax (syntax-expand (macro . arg))
  (syntax (syntax-object->datum ((macro <transformer>) (syntax (macro . arg))))))