#lang scheme/base

;; These utilities facilitate operations on syntax objects.
;; A syntax object that represents a parenthesized sequence
;; can contain a mixture of cons cells and syntax objects,
;; hence the need for `stx-null?', `stx-car', etc.

(provide stx-null? stx-pair? stx-list?
         stx-car stx-cdr stx->list
         module-or-top-identifier=?)

;; a syntax null?
(define (stx-null? p)
  (or (null? p)
      (and (syntax? p) 
           (null? (syntax-e p)))))

;; a syntax pair?
(define (stx-pair? p)
  (or (pair? p)
      (and (syntax? p)
           (pair? (syntax-e p)))))

;; a syntax list?
(define (stx-list? p)
  (or (list? p)
      (if (syntax? p) 
          (or (list? (syntax-e p))
              (let loop ([l (syntax-e p)])
                (if (pair? l)
                    (loop (cdr l))
                    (stx-list? l))))
          (and (pair? p)
               (stx-list? (cdr p))))))

;; car of a syntax pair
(define (stx-car p)
  (if (pair? p)
      (car p)
      (car (syntax-e p))))

;; cdr of a syntax pair
(define (stx-cdr p)
  (if (pair? p)
      (cdr p)
      (cdr (syntax-e p))))

;; Flattens a syntax list into a list
(define (stx->list e)
  (if (syntax? e)
      (syntax->list e)
      (let ([flat-end
             (let loop ([l e])
               (if (null? l) 
                   #f
                   (if (pair? l)
                       (loop (cdr l))
                       (if (syntax? l) 
                           (syntax->list l)
                           #f))))])
        (if flat-end
            ;; flatten
            (let loop ([l e])
              (if (null? l) 
                  null
                  (if (pair? l) 
                      (cons (car l) (loop (cdr l)))
                      (if (syntax? l) 
                          flat-end
                          #f))))
            e))))

(define (module-or-top-identifier=? a b)
  (or (free-identifier=? a b)
      (and (eq? (syntax-e a) (syntax-e b))
           (free-identifier=? a
                              (datum->syntax
                               #f
                               (syntax-e b))))))
